From e8cc18962e9f998dc5ef3990f6fc360596da3249 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 15 Jul 2026 04:17:00 +1000 Subject: [PATCH] _vfscommon.vfs: refresh built punk modules to current versions make.tcl vfscommonupdate output batched per src/AGENTS.md build-output policy: punk::ansi 0.1.2 -> 0.1.3, punk::args 0.12.0 -> 0.12.3, punk::lib 0.4.3 -> 0.5.0, punk::ns 0.5.0 -> 0.8.0, punk::repl 0.5.1 -> 0.5.2. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com --- .../punk/{ansi-0.1.2.tm => ansi-0.1.3.tm} | 21 +- .../punk/{args-0.12.0.tm => args-0.12.3.tm} | 1423 +++------------- .../punk/{lib-0.4.3.tm => lib-0.5.0.tm} | 99 +- .../modules/punk/{ns-0.5.0.tm => ns-0.8.0.tm} | 1476 ++--------------- .../punk/{repl-0.5.1.tm => repl-0.5.2.tm} | 9 +- 5 files changed, 447 insertions(+), 2581 deletions(-) rename src/vfs/_vfscommon.vfs/modules/punk/{ansi-0.1.2.tm => ansi-0.1.3.tm} (99%) rename src/vfs/_vfscommon.vfs/modules/punk/{args-0.12.0.tm => args-0.12.3.tm} (89%) rename src/vfs/_vfscommon.vfs/modules/punk/{lib-0.4.3.tm => lib-0.5.0.tm} (98%) rename src/vfs/_vfscommon.vfs/modules/punk/{ns-0.5.0.tm => ns-0.8.0.tm} (81%) rename src/vfs/_vfscommon.vfs/modules/punk/{repl-0.5.1.tm => repl-0.5.2.tm} (99%) diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.3.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.2.tm rename to src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.3.tm index 85694a26..be13f441 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.3.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ansi 0.1.2 +# Application punk::ansi 0.1.3 # Meta platform tcl # Meta license # @@ Meta End @@ -16,7 +16,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::ansi 0 0.1.2] +#[manpage_begin punkshell_module_punk::ansi 0 0.1.3] #[copyright "2023"] #[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] @@ -1336,6 +1336,8 @@ tcl::namespace::eval punk::ansi { @leaders -min 0 -max 0 @opts + #2026-07-14 Agent-Updated: summarydict choicelabel corrected - the linemap key is ALWAYS present + #(the old text claimed -n-only; behaviour pinned in tests ansi/grepstr.test) -r|-return -mash true -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches summarydict} -choicelabels { "matched"\ " Return only lines that matched." @@ -1350,13 +1352,12 @@ tcl::namespace::eval punk::ansi { indicator after the linenumber will only be highlighted for lines with matches, and the following matchcount will indicate zero for non-matching lines." "summarydict"\ - " Return a summary dict with keys 'matches', 'matchlines' and 'totallines' giving - the count of matched patterns, lines with matches and total number of lines - respectively. - If -n is also supplied, the summary dict will also include a 'linemap' key - with a dict value mapping line numbers (1-based) to match counts for each line. - This allows the caller to determine which lines had matches and how many - matches each line had, without returning the matched lines themselves. + " Return a summary dict with keys 'matches', 'matchlines', 'totallines' and + 'linemap' giving the count of matched patterns, lines with matches, total + number of lines, and a dict mapping line numbers (1-based) to match counts + for each line respectively. + The linemap allows the caller to determine which lines had matches and how + many matches each line had, without returning the matched lines themselves. " } -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num @@ -13640,7 +13641,7 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ansi [tcl::namespace::eval punk::ansi { variable version - set version 0.1.2 + set version 0.1.3 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.12.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.12.3.tm similarity index 89% rename from src/vfs/_vfscommon.vfs/modules/punk/args-0.12.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args-0.12.3.tm index 33388cdb..cac1f523 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.12.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.12.3.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.12.0 +# Application punk::args 0.12.3 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.12.0] +#[manpage_begin punkshell_module_punk::args 0 0.12.3] #[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 --}] @@ -68,7 +68,7 @@ #}] #[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls #[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]valid @ directive lines begin with @id @cmd @form @leaders @opts @values @formdisplay @doc @examples (plus the bare directives @dynamic and @normalize) #[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. #[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. #[para]e.g the result from the punk::args::parse call above may be something like: @@ -84,15 +84,15 @@ # -translation -default binary # -nocomplain -type none # @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 +# fileA -type existingfile +# fileB -type existingfile # }]] leaders opts values # puts "$category fileA: [dict get $values fileA]" # puts "$category fileB: [dict get $values fileB]" # } #}] #[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]a Tk-style ordering can be achieved, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored #[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, #[para] or an additional call could be made to punk::args e.g #[example { @@ -2246,13 +2246,6 @@ tcl::namespace::eval punk::args { set instance_info {} set keywords_info {} set examples_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit set DEF_definition_id $id #form_defs @@ -6366,7 +6359,7 @@ tcl::namespace::eval punk::args { In the 'withid' form the definition is a pre-existing record that has been created with ::punk::args::define, or indirectly by adding a definition to the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse + punk::args::register::NAMESPACES, or by a previous call to punk::args::parse using 'withdef' and a definition block containing an @id -id directive. In the 'withdef' form - the definition is created on the first call and @@ -6391,8 +6384,9 @@ tcl::namespace::eval punk::args { } proc myfunc {args} { set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { + set opts [dict get $argd opts] + set received [dict get $argd received] + if {[dict exists $received -configfile]} { puts "have option for existing file [dict get $opts -configfile]" } } @@ -6402,13 +6396,13 @@ tcl::namespace::eval punk::args { The received key is dict-like but can have repeated keys for arguments than can accept multiples. The value for each received element is the ordinal position of each clause. - ie in the common case where each argument is a single value, the ordinal positiion - will correspond too the position of the argument in the arglist. But if an argument can be + ie in the common case where each argument is a single value, the ordinal position + will correspond to the position of the argument in the arglist. But if an argument can be a clause of multiple values (possibly with some values in the clause being optional), then there will not be a direct correlation between the position of the argument in the arglist and the ordinal position of the clause received for that argument. An example of a multivalued clause is an argument defined with a -type that has multiple elements, - e.g coord -type {int int}. This is a dictinct situation to an argument defined with -multiple true + e.g coord -type {int int}. This is a distinct situation to an argument defined with -multiple true where the argument can be repeated but each clause is a single value. In the coord example, if it is also designated with -multiple true, the first clause received for the coord argument would have an ordinal position of 0, and the second clause received for the coord argument would @@ -7836,6 +7830,15 @@ tcl::namespace::eval punk::args { } set tp [string trim $tp ?] #puts "private::get_dict_can_assign_value: checking tp '$tp' against value '$rv'" + #------------------------------------------------------------------- + #2026-07-14 Agent-Updated + #A disabled XXXliteral* arm (superseded by the literal(* arm) was + #removed from the switch below. Still open from it: literalprefix(...) + #members are not handled in this multi-member tail-clause walk (only + #exact literal(...) - the single-member path above does handle + #literalprefix). Note: comments must never be placed between the + #switch arms themselves. + #------------------------------------------------------------------- switch -glob -- $tp { "literal(*" { set litmatch [string range $tp 8 end-1] @@ -7851,26 +7854,15 @@ tcl::namespace::eval punk::args { } } } - XXXliteral* { - #JJJ - set litinfo [string range $tp 7 end] - set match [string range $litinfo 1 end-1] - #todo -literalprefix - if {$rv eq $match} { - set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok - incr alloc_count - } else { - if {$clause_member_optional} { - # - } else { - set alloc_ok 0 - break - } - } - } "stringstartswith(*" { set pfx [string range $tp 17 end-1] - if {[string match "$pfx*" $tp]} { + #2026-07-14 Agent-Updated: fixed - this previously matched + #against $tp (the type string) rather than $rv (the value), + #so matching trailing words were never reserved for the tail + #clause and a prefix text prefixing the literal type string + #wrongly reserved non-matching words (spurious overflow). + #Pinned by allocation_tailclause_ssw_reservation (allocation.test). + if {[string match "$pfx*" $rv]} { set alloc_ok 1 incr alloc_count } else { @@ -7930,7 +7922,9 @@ tcl::namespace::eval punk::args { set num_remaining [llength $all_remaining] if {[dict get $ARG_INFO $thisname -optional] || ([dict get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived)} { - #todo - check -multiple for required min/max (not implemented: make -multiple accept ?) + #2026-07-14 Agent-Updated: occurrence min/max for -multiple is goal G-053 + #(proposed: -multiple accepts a {min max} range alongside the legacy booleans). + #Not implemented - only boolean -multiple semantics apply here. #thisname already satisfied, or not required set tail_needs 0 foreach t $tailnames { @@ -7993,6 +7987,10 @@ tcl::namespace::eval punk::args { lassign [Dict_getdef $ARG_INFO $thisname -choicemultiple {1 1}] cw_cmmin cw_cmmax } } + #G-082: when a screen (choice/basic-type) rejects the candidate word for a + #single-member clause, the reason is recorded here and returned so the caller + #can prefer the specific rejection over a generic overflow at raise time. + set rejection {} 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] @@ -8188,6 +8186,17 @@ tcl::namespace::eval punk::args { } } else { set alloc_ok 0 + #G-082: single-member clause only - the shapes where the rejected + #word and a subsequently-overflowing word are the same word. + #Literal-category mismatches are deliberately not recorded (syntax + #words like lseq's 'to' - overflow remains the clearer report). + if {[llength $thistype] == 1} { + if {$member_choicechecked} { + set rejection [tcl::dict::create kind choice argname $thisname word $v choices $cw_allchoices nocase $cw_nocase prefix $cw_prefix] + } elseif {[llength $ctg_other]} { + set rejection [tcl::dict::create kind type argname $thisname word $v type $tp] + } + } } } @@ -8203,10 +8212,10 @@ tcl::namespace::eval punk::args { #such elements shouldn't be subject to validation if {$alloc_ok} { #puts stderr ">>>private::get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" - set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] + set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist rejection {}] } else { #puts stderr ">>>private::get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" - set d [dict create consumed 0 resultlist {} typelist $thistype] + set d [dict create consumed 0 resultlist {} typelist $thistype rejection $rejection] } #puts ">>>> private::get_dict_can_assign_value $d" return $d @@ -8291,406 +8300,19 @@ tcl::namespace::eval punk::args { } } - #old version - ###proc private::check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn type_expression clausevalues_raw clausevalues_check argspecs} { - ### #set type $type_expression ;#todo - 'split' on | - ### set vlist $clausevalues_raw - ### set vlist_check $clausevalues_check - - ### set type_alternatives [private::split_type_expression $type_expression] - ### #each type_alternative is a list of varying length depending on arguments supported by first word. - ### #TODO? - ### #single element types: int double string etc - ### #two element types literal literalprefix stringstartswith stringendswith - ### #TODO - ### set stype [lindex $type_alternatives 0] - ### #e.g int - ### #e.g {literal blah)etc} - ### set type [lindex $stype 0] - ### #switch on first word of each stype - ### # - - ### #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? - ### switch -- $type { - ### any {} - ### literal { - ### foreach clauseval $vlist { - ### set e [lindex $clauseval $clausecolumn] - ### set testval [lindex $stype 1] - ### if {$e ne $testval} { - ### set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### stringstartwith { - ### foreach clauseval $vlist { - ### set e [lindex $clauseval $clausecolumn] - ### set testval [lindex $stype 1] - ### if {![string match $testval* $e]} { - ### set msg "$argclass '$argname' for %caller% requires stringstartswith value '$argname'. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### list { - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is list -strict $e_check]} { - ### set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - ### } - ### if {[tcl::dict::size $thisarg_checks]} { - ### tcl::dict::for {checkopt checkval} $thisarg_checks { - ### switch -- $checkopt { - ### -minsize { - ### # -1 for disable is as good as zero - ### if {[llength $e_check] < $checkval} { - ### set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### -maxsize { - ### if {$checkval ne "-1"} { - ### if {[llength $e_check] > $checkval} { - ### set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### } - ### } - ### indexexpression { - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {[catch {lindex {} $e_check}]} { - ### set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### string - ansistring - globstring { - ### #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - ### #we possibly don't want to always have to regex on things that don't pass the other more basic checks - ### # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - ### # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - ### # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - ### # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - ### # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - ### # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - ### #todo? - way to validate both unstripped and stripped? - ### set pass_quick_list_e [list] - ### set pass_quick_list_e_check [list] - ### set remaining_e $vlist - ### set remaining_e_check $vlist_check - ### #review - order of -regexprepass and -regexprefail in original rawargs significant? - ### #for now -regexprepass always takes precedence - ### set regexprepass [tcl::dict::get $thisarg -regexprepass] - ### set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - ### if {$regexprepass ne ""} { - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {[regexp [lindex $regexprepass $clausecolumn] $e]} { - ### lappend pass_quick_list_e $clauseval - ### lappend pass_quick_list_e_check $clauseval_check - ### } - ### } - ### set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - ### set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - ### } - ### if {$regexprefail ne ""} { - ### foreach clauseval $remaining_e clauseval_check $remaining_e_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### #puts "----> checking $e vs regex $regexprefail" - ### if {[regexp $regexprefail $e]} { - ### if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - ### #review - %caller% ?? - ### set msg [tcl::dict::get $thisarg -regexprefailmsg] - ### } else { - ### set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - ### } - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### switch -- $type { - ### ansistring { - ### #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - ### #.. so we need to look at the original values in $vlist not $vlist_check - - ### #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - ### #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - ### package require punk::ansi - ### foreach clauseval $remaining_e { - ### set e [lindex $clauseval $clausecolumn] - ### if {![punk::ansi::ta::detect $e]} { - ### set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### globstring { - ### foreach clauseval $remaining_e { - ### set e [lindex $clauseval $clausecolumn] - ### if {![regexp {[*?\[\]]} $e]} { - ### set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - - ### if {[tcl::dict::size $thisarg_checks]} { - ### foreach clauseval $remaining_e_check { - ### set e_check [lindex $clauseval $clausecolumn] - ### if {[dict exists $thisarg_checks -minsize]} { - ### set minsize [dict get $thisarg_checks -minsize] - ### # -1 for disable is as good as zero - ### if {[tcl::string::length $e_check] < $minsize} { - ### set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### if {[dict exists $thisarg_checks -maxsize]} { - ### set maxsize [dict get $thisarg_checks -maxsize] - ### if {$checkval ne "-1"} { - ### if {[tcl::string::length $e_check] > $maxsize} { - ### set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### number { - ### #review - consider effects of Nan and Inf - ### #NaN can be considered as 'technically' a number (or at least a special numeric value) - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - ### set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### if {[tcl::dict::exists $thisarg -typeranges]} { - ### set ranges [tcl::dict::get $thisarg -typeranges] - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set range [lindex $ranges $clausecolumn] - ### lassign {} low high ;#set both empty - ### lassign $range low high - - ### if {"$low$high" ne ""} { - ### if {[::tcl::mathfunc::isnan $e]} { - ### set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### if {$low eq ""} { - ### if {$e_check > $high} { - ### set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } elseif {$high eq ""} { - ### if {$e_check < $low} { - ### set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } else { - ### if {$e_check < $low || $e_check > $high} { - ### set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### int { - ### #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is integer -strict $e_check]} { - ### set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### if {[tcl::dict::exists $thisarg -typeranges]} { - ### set ranges [tcl::dict::get $thisarg -typeranges] - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set range [lindex $ranges $clausecolumn] - ### lassign $range low high - ### if {"$low$high" ne ""} { - ### if {$low eq ""} { - ### #lowside unspecified - check only high - ### if {$e_check > $high} { - ### set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } elseif {$high eq ""} { - ### #highside unspecified - check only low - ### if {$e_check < $low} { - ### set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } else { - ### #high and low specified - ### if {$e_check < $low || $e_check > $high} { - ### set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### double { - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is double -strict $e_check]} { - ### set e [lindex $clauseval $clausecolumn] - ### set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### if {[tcl::dict::size $thisarg_checks]} { - ### if {[dict exists $thisarg_checks -typeranges]} { - ### set ranges [dict get $thisarg_checks -typeranges] - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set range [lindex $ranges $clausecolumn] - ### #todo - small-value double comparisons with error-margin? review - ### #todo - empty string for low or high - ### lassign $range low high - ### if {$e_check < $low || $e_check > $high} { - ### set e [lindex $clauseval $clausecolumn] - ### set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### bool { - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is boolean -strict $e_check]} { - ### set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### dict { - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {[llength $e_check] %2 != 0} { - ### set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### if {[tcl::dict::size $thisarg_checks]} { - ### if {[dict exists $thisarg_checks -minsize]} { - ### set minsizes [dict get $thisarg_checks -minsize] - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set minsize [lindex $minsizes $clausecolumn] - ### # -1 for disable is as good as zero - ### if {[tcl::dict::size $e_check] < $minsize} { - ### set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### if {[dict exists $thisarg_checks -maxsize]} { - ### set maxsizes [dict get $thisarg_checks -maxsize] - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set maxsize [lindex $maxsizes $clausecolumn] - ### if {$maxsize ne "-1"} { - ### if {[tcl::dict::size $e_check] > $maxsize} { - ### set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### alnum - - ### alpha - - ### ascii - - ### control - - ### digit - - ### graph - - ### lower - - ### print - - ### punct - - ### space - - ### upper - - ### wordchar - - ### xdigit { - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is $type -strict $e_check]} { - ### set e [lindex $clauseval $t] - ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### file - - ### directory - - ### existingfile - - ### existingdirectory { - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### #//review - we may need '?' char on windows - ### if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>]} $e_check])} { - ### #what about special file names e.g on windows NUL ? - ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### if {$type eq "existingfile"} { - ### if {![file exists $e_check]} { - ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - ### } - ### } elseif {$type eq "existingdirectory"} { - ### if {![file isdirectory $e_check]} { - ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### char { - ### #review - char vs unicode codepoint vs grapheme? - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {[tcl::string::length $e_check] != 1} { - ### set e [lindex $clauseval $clausecolumn] - ### set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### default { - ### } - ### } - - ###} - - #new version + + #------------------------------------------------------------------------------- + #2026-07-14 Agent-Updated + #Two superseded commented-out implementations were removed here (see git history + #prior to punkshell 0.12.28 if needed): + # - the pre-typelist-signature 'old version' of private::check_clausecolumn + # - '_check_clausecolumn2', an abandoned 'interim version' experiment whose one + # idea worth keeping was: collect per-clause validation results in a + # clause_results structure and report at the end, instead of raising on the + # first failing clause. If clause validation is reworked (e.g G-072 compound + # clause types / per-alternate handlers), that error-collection approach is a + # candidate shape. + #------------------------------------------------------------------------------- #list_of_clauses_raw list of (possibly)multi-value clauses for a particular argname #common basic case: list of single item being a single value clause. #precondition: list_of_clauses_raw has 'list protected' clauses of length 1 e.g if value is a dict {a A} @@ -9379,717 +9001,6 @@ tcl::namespace::eval punk::args { } - ##interim version - ##list_of_clauses_raw list of (possibly)multi-value clauses for a particular argname - ##common basic case: list of single item being a single value clause. - ##precondition: list_of_clauses_raw has 'list protected' clauses of length 1 e.g if value is a dict {a A} - #proc _check_clausecolumn2 {argname argclass thisarg thisarg_checks clausecolumn type_expression list_of_clauses_raw list_of_clauses_check argspecs} { - # if {$argname eq "frametype"} { - # puts "--->checking arg:$argname clausecolumn:$clausecolumn checkvalues:[lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] against type_expression $type_expression" - # puts "--->list_of_clauses_raw : $list_of_clauses_raw" - # puts "--->list_of_clauses_check: $list_of_clauses_check" - # puts "--->$argname -type: [dict get $thisarg -type]" - # } - - # set clause_size [llength [dict get $thisarg -type]] ;#length of full type - not just passed type_expression - - # #set vlist [list] - # set clauses_dict [dict create] ;#key is ordinal position, remove entries as they are satsified - # set cidx -1 - # foreach cv $list_of_clauses_raw { - # incr cidx - # #REVIEW - # #if {$clause_size ==1} { - # # lappend vlist [list $cidx [list $cv]] - # #} else { - # #lappend vlist [list $cidx $cv] ;#store the index so we can reduce vlist as we go - # dict set clauses_dict $cidx $cv - # #} - # } - # #set vlist_check [list] - # set clauses_dict_check [dict create] - # set cidx -1 - # foreach cv $list_of_clauses_check { - # incr cidx - # #if {$clause_size == 1} { - # # lappend vlist_check [list $cidx [list $cv]] - # #} else { - # #lappend vlist_check [list $cidx $cv] - # dict set clauses_dict_check $cidx $cv - # #} - # } - - # set type_alternatives [private::split_type_expression $type_expression] - # #each type_alternative is a list of varying length depending on arguments supported by first word. - # #TODO? - # #single element types: int double string etc - # #two element types literal literalprefix stringstartswith stringendswith - # #TODO - - # #list for each clause (each clause is itself a list - usually length 1 but can be any length - we are dealing only with one column of the clauses) - # set clause_results [lrepeat [llength $list_of_clauses_raw] [lrepeat [llength $type_alternatives] _]] - # #e.g for list_of_clauses_raw {{a b c} {1 2 3}} when clausecolumn is 0 - # #-types {int|char|literal(ok) char double} - # #we are checking a and 1 against the type_expression int|char|literal(ok) (type_alternatives = {int char literal(ok)} - # #our initial clause_results in this case is a 2x2 list {{_ _ _} {_ _ _}} - # # - - - # set a_idx -1 - # foreach typealt $type_alternatives { - # incr a_idx - - # set type [lindex $typealt 0] - # #e.g int - # #e.g {literal blah} - # #e.g {literalprefix abc} - - # #switch on first word of each typealt - # # - - # #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? - # switch -- $type { - # any {} - # literal { - # dict for {c_idx clauseval} $clauses_dict { - # set e [lindex $clauseval $clausecolumn] - # set testval [lindex $typealt 1] - # if {$e ne $testval} { - # set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # #this clause is satisfied - no need to process it for other typealt - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # literalprefix { - # set alt_literals [lsearch -all -inline -index 0 $type_alternatives literal] - # set literals [lmap v $alt_literals {lindex $v 1}] - # set alt_literalprefixes [lsearch -all -inline -index 0 $type_alternatives literalprefix] - # set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}] - - # dict for {c_idx clauseval} $clauses_dict { - # set e [lindex $clauseval $clausecolumn] - # #this specific literalprefix value not relevant - we're testing against all in the set of typealternates - # #set testval [lindex $typealt 1] - # set match [::tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $e] - # if {$match ne "" && $match ni $literals} { - # lset clause_results $c_idx $a_idx 1 - # #this clause is satisfied - no need to process it for other typealt - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } else { - # set msg "$argclass '$argname' for %caller% requires unambiguous literal prefix match for one of '$literalprefixes' within prefix calculation set:'[list {*}$literals {*}$literalprefixes]'. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - # } - # } - # } - # stringstartswith { - # dict for {c_idx clauseval} $clauses_dict { - # set e [lindex $clauseval $clausecolumn] - # set testval [lindex $typealt 1] - # if {[string match $testval* $e]} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } else { - # set msg "$argclass '$argname' for %caller% requires stringstartswith value '$testval'. Received: '$e'" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - # } - # } - # } - # stringendswith { - # dict for {c_idx clauseval} $clauses_dict { - # set e [lindex $clauseval $clausecolumn] - # set testval [lindex $typealt 1] - # if {[string match *$testval $e]} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } else { - # set msg "$argclass '$argname' for %caller% requires stringendswith value '$testval'. Received: '$e'" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - # } - # } - # } - # list { - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # set passed_checks 1 - # if {![tcl::string::is list -strict $e_check]} { - # set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } else { - # if {[dict exists $thisarg_checks -minsize]} { - # # -1 for disable is as good as zero - # set minsize [dict get $thisarg_checks -minsize] - # if {[llength $e_check] < $minsize} { - # set msg "$argclass '$argname for %caller% requires list with -minsize $minsize. Received len:[llength $e_check]" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # if {$passed_checks && [dict exist $thisarg_checks -maxsize]} { - # set maxsize [dict get $thisarg_checks -maxsize] - # if {$maxsize ne "-1"} { - # if {[llength $e_check] > $maxsize} { - # set msg "$argclass '$argname for %caller% requires list with -maxsize $maxsize. Received len:[llength $e_check]" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # indexexpression { - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[catch {lindex {} $e_check}]} { - # set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # string - ansistring - globstring { - # #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - # #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - # #todo? - way to validate both unstripped and stripped? - # #review - order of -regexprepass and -regexprefail in original rawargs significant? - # #for now -regexprepass always takes precedence - # #REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults? - # set regexprepass [tcl::dict::get $thisarg -regexprepass] - # set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - # if {$regexprepass ne ""} { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[regexp [lindex $regexprepass $clausecolumn] $e]} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # if {$regexprefail ne ""} { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - # #puts "----> checking $e vs regex $regexprefail" - # if {[regexp $regexprefail $e]} { - # if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - # #review - %caller% ?? - # set msg [tcl::dict::get $thisarg -regexprefailmsg] - # } else { - # set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - # } - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs] msg $msg] - # #review - tests? - # } - # } - # } - # switch -- $type { - # ansistring { - # #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - # #.. so we need to look at the original values in $clauses_dict not $clauses_dict_check - - # #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - # #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - # package require punk::ansi - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e [lindex $clauseval $clausecolumn] - # if {![punk::ansi::ta::detect $e]} { - # set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # } - # globstring { - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e [lindex $clauseval $clausecolumn] - # if {![regexp {[*?\[\]]} $e]} { - # set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # } - # } - - # dict for {c_idx clauseval_check} $clauses_dict_check { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # if {[tcl::dict::size $thisarg_checks]} { - # set passed_checks 1 - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[dict exists $thisarg_checks -minsize]} { - # set minsize [dict get $thisarg_checks -minsize] - # # -1 for disable is as good as zero - # if {[tcl::string::length $e_check] < $minsize} { - # set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { - # set maxsize [dict get $thisarg_checks -maxsize] - # if {$checkval ne "-1"} { - # if {[tcl::string::length $e_check] > $maxsize} { - # set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } else { - # if {[lindex $clause_results $c_idx $a_idx] eq "_"} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # } - # number { - # #review - consider effects of Nan and Inf - # #NaN can be considered as 'technically' a number (or at least a special numeric value) - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - # set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # if {[tcl::dict::exists $thisarg -typeranges]} { - # set ranges [tcl::dict::get $thisarg -typeranges] - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - # set range [lindex $ranges $clausecolumn] - # lassign {} low high ;#set both empty - # lassign $range low high - # set passed_checks 1 - # if {"$low$high" ne ""} { - # if {[::tcl::mathfunc::isnan $e]} { - # set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # if {$passed_checks} { - # if {$low eq ""} { - # if {$e_check > $high} { - # set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } elseif {$high eq ""} { - # if {$e_check < $low} { - # set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } else { - # if {$e_check < $low || $e_check > $high} { - # set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict usnet clauses_dict_check $c_idx - # } - # } - # } else { - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict usnet clauses_dict_check $c_idx - # } - # } - - # } - # int { - # #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # if {![tcl::string::is integer -strict $e_check]} { - # set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # if {[tcl::dict::exists $thisarg -typeranges]} { - # set ranges [tcl::dict::get $thisarg -typeranges] - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - # set range [lindex $ranges $clausecolumn] - # lassign $range low high - # set passed_checks 1 - # if {"$low$high" ne ""} { - # if {$low eq ""} { - # #lowside unspecified - check only high - # if {$e_check > $high} { - # set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } elseif {$high eq ""} { - # #highside unspecified - check only low - # if {$e_check < $low} { - # set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } else { - # #high and low specified - # if {$e_check < $low || $e_check > $high} { - # set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } else { - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # double { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # set e_check [lindex $clauseval_check $clausecolumn] - # if {![tcl::string::is double -strict $e_check]} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # if {[tcl::dict::exists $thisarg_checks -typeranges]} { - # set ranges [dict get $thisarg_checks -typeranges] - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e_check [lindex $clauseval_check $clausecolumn] - # set range [lindex $ranges $clausecolumn] - # #todo - small-value double comparisons with error-margin? review - # #todo - empty string for low or high - # set passed_checks 1 - # lassign $range low high - # if {$low$high ne ""} { - # if {$e_check < $low || $e_check > $high} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } else { - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # bool { - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # if {![tcl::string::is boolean -strict $e_check]} { - # set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # dict { - # dict for {c_idx clauseval_check} $clauses_dict_check { - # puts "check_clausecolumn2 dict handler: c_idx:$c_idx clausecolumn:$clausecolumn clauseval_check:$clauseval_check" - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[llength $e_check] %2 != 0} { - # set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - # } - # } - # dict for {c_idx clauseval_check} $clauses_dict_check { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set passed_checks 1 - # if {[tcl::dict::size $thisarg_checks]} { - # if {[dict exists $thisarg_checks -minsize]} { - # set minsizes [dict get $thisarg_checks -minsize] - # set e_check [lindex $clauseval_check $clausecolumn] - # set minsize [lindex $minsizes $clausecolumn] - # # -1 for disable is as good as zero - # if {[tcl::dict::size $e_check] < $minsize} { - # set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { - # set e_check [lindex $clauseval_check $clausecolumn] - # set maxsize [lindex $maxsizes $clausecolumn] - # if {$maxsize ne "-1"} { - # if {[tcl::dict::size $e_check] > $maxsize} { - # set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # } - - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # alnum - - # alpha - - # ascii - - # control - - # digit - - # graph - - # lower - - # print - - # punct - - # space - - # upper - - # wordchar - - # xdigit { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # set e_check [lindex $clauseval_check $clausecolumn] - # if {![tcl::string::is $type -strict $e_check]} { - # set e [lindex $clauseval $t] - # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # file - - # directory - - # existingfile - - # existingdirectory { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - - # #//review - we may need '?' char on windows - # set passed_checks 1 - # if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - # #what about special file names e.g on windows NUL ? - # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # if {$passed_checks} { - # if {$type eq "existingfile"} { - # if {![file exists $e_check]} { - # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } elseif {$type eq "existingdirectory"} { - # if {![file isdirectory $e_check]} { - # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # char { - # #review - char vs unicode codepoint vs grapheme? - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[tcl::string::length $e_check] != 1} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # tk_screen_units { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - - # set e_check [lindex $clauseval_check $clausecolumn] - # set passed_checks 1 - # switch -exact -- [string index $e_check end] { - # c - i - m - p { - # set numpart [string range $e_check 0 end-1] - # if {![tcl::string::is double $numpart]} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # default { - # if {![tcl::string::is double $e_check]} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # default { - # #default pass for unrecognised types - review. - # dict for {c_idx clauseval} $clauses_dict { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # } - # foreach clauseresult $clause_results { - # if {[lsearch $clauseresult 1] == -1} { - # #no pass for this clause - fetch first? error and raise - # #todo - return error containing clause_indices so we can report more than one failing element at once? - # foreach e $clauseresult { - # if {[lindex $e 0] eq "errorcode"} { - # #errorcode msg values + #[para]Parse rawargs as a sequence of zero or more leaders, zero or more options (solo flags, -flag value pairs, mashes, --long=value), and zero or more values + #[para]Returns a dict with keys: leaders opts values received solos multis id form (plus formstatus when multiform candidacy ran) #[para]ARGUMENTS: #[list_begin arguments] #[arg_def list-of-multiline-string deflist] @@ -10336,8 +9251,8 @@ tcl::namespace::eval punk::args { #[para]argumentname -key val -ky2 val2... #[para]where the valid keys for each option specification are: -default -type -range -choices #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[para]directive lines beginning with @id @cmd @form @leaders @opts @values @formdisplay @doc @examples (plus bare @dynamic and @normalize) take -key val pairs and set defaults or control settings. + #[para]@leaders @opts and @values lines can appear multiple times with defaults affecting the argument lines that follow. #[arg_def list rawargs] #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, #but it could be a manually constructed list of values made for example from positional args defined in the proc. @@ -10512,6 +9427,13 @@ tcl::namespace::eval punk::args { set FORMDISPLAY [dict get $formdict FORMDISPLAY] + #G-082 single-form error selection: words the allocation screens rejected for an + #OPTIONAL argument (restricted choices, basic type), keyed by the word itself. + #First rejection per word wins (nearest/earliest defined argument - the one the + #caller most plausibly intended). Consulted only if the word later overflows - + #a word consumed by a later slot leaves its entry unused. + set alloc_rejections [dict create] + if {$VAL_MIN eq ""} { set valmin 0 #set VAL_MIN 0 @@ -10732,7 +9654,11 @@ tcl::namespace::eval punk::args { incr ridx $consumed incr ridx -1 ;#leave ridx at index of last r that we set } else { - + #G-082: keep the screen's rejection (if any) for error selection at overflow time + set rj [dict get $assign_d rejection] + if {$rj ne "" && ![dict exists $alloc_rejections [dict get $rj word]]} { + dict set alloc_rejections [dict get $rj word] $rj + } } if {!$is_multiple} { incr nameidx @@ -11134,7 +10060,7 @@ tcl::namespace::eval punk::args { lappend multisreceived $api_opt } } else { - #test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence} + #2026-07-14 Agent-Updated: pinned by test parsekey_repeat_ordering (tests args/parsekey.test) - last flag must have precedence #tcl::dict::set opts $flag_ident $tdflt if {$flag_ident_is_parsekey} { #(shimmer - but required for ordering correctness during override) @@ -11376,7 +10302,7 @@ tcl::namespace::eval punk::args { lappend multisreceived $api_opt } } else { - #test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence} + #2026-07-14 Agent-Updated: pinned by test parsekey_repeat_ordering (tests args/parsekey.test) - last flag must have precedence #tcl::dict::set opts $flag_ident $tdflt if {$flag_ident_is_parsekey} { #(shimmer - but required for ordering correctness during override) @@ -11507,41 +10433,13 @@ tcl::namespace::eval punk::args { } - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> arglist: $arglist" - #puts stderr "get_dict--> leaders: $leaders" - #puts stderr "get_dict--> values: $values" - #} - #--------------------------------------- #Order the received options by the order in which they are *defined* #EXCEPT that grouped options using same parsekey must be processed in received order + #(2026-07-14 Agent-Updated: a superseded simpler ordering loop that ignored + #received-order for shared parsekeys was removed here - see git history pre 0.12.28) set ordered_opts [dict create] - #set unaliased_opts [lmap v $OPT_NAMES {string trimright [lindex [split $v |] end] =}] - ##unaliased_opts is list of 'api_opt' (to handle flag aliases of form -a1|-a2|-api_opt) - ## e.g -fg|-foreground - ## e.g -x|--fullname= - ##Resulting unaliased_opts from list {-fg|-foreground -x|--fullname=} should be {-foreground --fullname} - #foreach o $unaliased_opts optset $OPT_NAMES { - # if {[dict exists $opts $o]} { - # dict set ordered_opts $o [dict get $opts $o] - # } elseif {[dict exists $OPT_DEFAULTS $optset]} { - # #JJJ - # set parsekey "" - # if {[tcl::dict::exists $argstate $o -parsekey]} { - # set parsekey [tcl::dict::get $argstate $o -parsekey] - # } - # if {$parsekey eq ""} { - # set parsekey $o - # } - # dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset] - # } - #} - - #puts ">>>>====opts: $opts" set seen_pks [list] #treating opts as list for this loop. foreach optset $OPT_NAMES { @@ -11647,7 +10545,24 @@ tcl::namespace::eval punk::args { set start_position $positionalidx set nameidx 0 - #MAINTENANCE - (*nearly*?) same loop logic as for value + #------------------------------------------------------------------------------- + #2026-07-14 Agent-Updated (was: "MAINTENANCE - (*nearly*?) same loop logic as for value") + #MAINTENANCE: this leaders loop and the values loop below are deliberate near-clones. + #Shared logic: per-word get_dict_can_assign_value, optional-skip/required-raise on + #consumed==0, clause assembly, -multiple collection, received/typestate bookkeeping, + #-unnamed fallback, and the G-082 alloc_rejections overflow error selection. + #Known asymmetries: interplay with the upstream leader/value split, + #LEADER_TAKEWHENARGSMODULO, missingrequiredleader vs missingrequiredvalue, and the + #values loop's api_valname (-parsekey) identifiers which this loop lacks (G-084). + #Refactor assessment (2026-07-14): folding both loops into one clause-assignment + #helper is indicated - drift is real (G-082 had to duplicate its selection block; + #parsekey idents exist only on the values side) - but it should ride the G-084 + #leaders/values parsekey parity work, which must touch both loops anyway, and must + #respect the parse hot-path constraints established by G-046: naive proc extraction + #means heavy state plumbing (upvar/dict) for many loop-local variables. Until then, + #any edit to one loop must be mirrored in the other or the divergence justified in + #a comment at the point of divergence. + #------------------------------------------------------------------------------- for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { set leadername [lindex $LEADER_NAMES $nameidx] set ldr [lindex $leaders $ldridx] @@ -11660,6 +10575,11 @@ tcl::namespace::eval punk::args { set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] if {$consumed == 0} { + #G-082: keep the screen's rejection (if any) for error selection at overflow time + set rj [dict get $assign_d rejection] + if {$rj ne "" && ![dict exists $alloc_rejections [dict get $rj word]]} { + dict set alloc_rejections [dict get $rj word] $rj + } if {[tcl::dict::get $argstate $leadername -optional]} { #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?" @@ -11703,8 +10623,10 @@ tcl::namespace::eval punk::args { # allow any value instead of 'then' to pass. #see argument_clause_typestate in value processing loop below for more handling of this issue regarding -multiple true clauses with optional subelements - #todo - synchronize with value processing loop below - #- consider refactor to a common procedure for handling this issue of tracking updated typelist state for optional subelements in -multiple true clauses + #2026-07-14 Agent-Updated: the "synchronize with the values loop / + #refactor to a common procedure" todo that lived here is subsumed by + #the MAINTENANCE refactor assessment at the head of this leaders loop + #(shared-helper refactor deferred to ride the G-084 parity work). #incorrect -don't update default -type info. #tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries @@ -11759,6 +10681,37 @@ tcl::namespace::eval punk::args { tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } else { + #G-082 single-form error selection: if this unassignable word was + #rejected by an optional argument's allocation screen, report that + #specific rejection instead of the generic overflow. + if {[dict exists $alloc_rejections $ldr]} { + set rj [dict get $alloc_rejections $ldr] + set rj_argname [dict get $rj argname] + if {$rj_argname in $LEADER_NAMES} { + set rj_argclass "Leading argument" + } else { + set rj_argclass "Trailing argument" + } + if {[dict get $rj kind] eq "choice"} { + if {[dict get $rj nocase]} { + set rj_casemsg " (case insensitive)" + } else { + set rj_casemsg " (case sensitive)" + } + if {[dict get $rj prefix]} { + set rj_prefixmsg " (or a unique prefix of a value)" + } else { + set rj_prefixmsg "" + } + set rj_choices [dict get $rj choices] + set msg "$rj_argclass '$rj_argname' for %caller% must be one of the listed values:\n [join $rj_choices "\n "]\n$rj_casemsg$rj_prefixmsg. Received: '$ldr'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $ldr choices $rj_choices] -badarg $rj_argname -badval $ldr -argspecs $argspecs]] $msg + } else { + set rj_type [dict get $rj type] + set msg "$rj_argclass '$rj_argname' for %caller% requires type '$rj_type'. Received: '$ldr'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $rj_type] -badarg $rj_argname -badval $ldr -argspecs $argspecs]] $msg + } + } set msg "Bad number of leaders for %caller%. Received more leaders than can be assigned to argument names. (set '@leaders -unnamed true' to allow unnamed leaders)" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg } @@ -11799,9 +10752,7 @@ tcl::namespace::eval punk::args { set valname_multiple "" set valnames_received [list] - #xxxxxxxxxxxxxxxxxx set api_valnames_received [list] - #xxxxxxxxxxxxxxxxxx set num_values [llength $values] #------------------------------------------ @@ -11819,12 +10770,18 @@ tcl::namespace::eval punk::args { set nameidx 0 set start_position $positionalidx set seen_pks [list] - #MAINTENANCE - (*nearly*?) same loop logic as for leaders + #2026-07-14 Agent-Updated (was: "MAINTENANCE - (*nearly*?) same loop logic as for leaders") + #MAINTENANCE: near-clone of the leaders loop above - see the refactor assessment + #comment there (shared logic, known asymmetries, defer-to-G-084 decision). + #Any edit here must be mirrored in the leaders loop or justified at the divergence. for {set validx 0} {$validx < [llength $values]} {incr validx} { set valname [lindex $VAL_NAMES $nameidx] set val [lindex $values $validx] #---------------------------------- - #todo + #2026-07-14 Agent-Updated (was a bare "#todo"): values/leaders -parsekey + #completeness is goal G-084 - this api_valname derivation is the values-side + #start of it (currently a value's -parsekey aborts parse further on, and the + #leaders loop has no equivalent). set api_valname "" if {[tcl::dict::exists $argstate $valname -parsekey]} { set api_valname [tcl::dict::get $argstate $valname -parsekey] @@ -11845,23 +10802,12 @@ tcl::namespace::eval punk::args { } lappend seen_pks $api_valname #---------------------------------- - #xxxxxxxxxxxxxxxxxxxxx - # if {[tcl::dict::get $argstate $optionset -parsekey] ne ""} { - # set api_opt [dict get $argstate $optionset -parsekey] - # } else { - # set api_opt [string trimright [lindex $raw_optionset_members end] =] - # } - # if {$api_opt eq $flagname} { - # set flag_ident $api_opt - # set flag_ident_is_parsekey 0 - # } else { - # #initially key our opts on a long form allowing us to know which specific flag was used - # #(for when multiple map to same parsekey e.g lsearch) - # #e.g -increasing|-SORTOPTION - # set flag_ident $flagname|$api_opt - # set flag_ident_is_parsekey 1 - # } - #xxxxxxxxxxxxxxxxxxxxx + #2026-07-14 Agent-Updated: a pasted reference copy of the opts-path + #flag_ident/-parsekey logic was removed here (the val_ident derivation + #above is its values-loop analogue). Values/leaders -parsekey support is + #incomplete - see goal G-084 (parse currently errors for a value's + #-parsekey and ignores a leader's). + #---------------------------------- if {$valname ne ""} { set valtypelist [tcl::dict::get $argstate $valname -type] set clause_size [llength $valtypelist] ;#common case is clause_size == 1 @@ -11871,6 +10817,11 @@ tcl::namespace::eval punk::args { set resultlist [dict get $assign_d resultlist] set newtypelist [dict get $assign_d typelist] if {$consumed == 0} { + #G-082: keep the screen's rejection (if any) for error selection at overflow time + set rj [dict get $assign_d rejection] + if {$rj ne "" && ![dict exists $alloc_rejections [dict get $rj word]]} { + dict set alloc_rejections [dict get $rj word] $rj + } if {[tcl::dict::get $argstate $valname -optional]} { #error 333 #puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" @@ -11967,6 +10918,38 @@ tcl::namespace::eval punk::args { tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS lappend valnames_received $positionalidx } else { + #G-082 single-form error selection: if this unassignable word was + #rejected by an optional argument's allocation screen, report that + #specific rejection instead of the generic overflow. + #(MAINTENANCE - same selection logic as leaders loop above) + if {[dict exists $alloc_rejections $val]} { + set rj [dict get $alloc_rejections $val] + set rj_argname [dict get $rj argname] + if {$rj_argname in $LEADER_NAMES} { + set rj_argclass "Leading argument" + } else { + set rj_argclass "Trailing argument" + } + if {[dict get $rj kind] eq "choice"} { + if {[dict get $rj nocase]} { + set rj_casemsg " (case insensitive)" + } else { + set rj_casemsg " (case sensitive)" + } + if {[dict get $rj prefix]} { + set rj_prefixmsg " (or a unique prefix of a value)" + } else { + set rj_prefixmsg "" + } + set rj_choices [dict get $rj choices] + set msg "$rj_argclass '$rj_argname' for %caller% must be one of the listed values:\n [join $rj_choices "\n "]\n$rj_casemsg$rj_prefixmsg. Received: '$val'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $val choices $rj_choices] -badarg $rj_argname -badval $val -argspecs $argspecs]] $msg + } else { + set rj_type [dict get $rj type] + set msg "$rj_argclass '$rj_argname' for %caller% requires type '$rj_type'. Received: '$val'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $rj_type] -badarg $rj_argname -badval $val -argspecs $argspecs]] $msg + } + } set msg "Bad number of values for %caller%. Received more values than can be assigned to argument names. (set '@values -unnamed true' to allow unnamed values)" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg } @@ -11989,10 +10972,6 @@ tcl::namespace::eval punk::args { } } #----------------------------------------------------- - #JJJJJJ - #if {[dict size $argument_clause_typestate]} { - # puts ">>>>>[dict get $argspecs id] typestate $argument_clause_typestate" - #} if {$leadermax == -1} { #only check min @@ -14847,7 +13826,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.12.0 + set version 0.12.3 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.3.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.5.0.tm similarity index 98% rename from src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.3.tm rename to src/vfs/_vfscommon.vfs/modules/punk/lib-0.5.0.tm index cac04588..432617c0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.4.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.5.0.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::lib 0.4.3 +# Application punk::lib 0.5.0 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.4.3] +#[manpage_begin punkshell_module_punk::lib 0 0.5.0] #[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 --}] @@ -292,7 +292,7 @@ tcl::namespace::eval punk::lib::check { 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). + #scripts) then fails before any load (0.5.0 dev modules are alpha - below 999999). catch {package require punk::repl 999999} set available [package versions punk::repl] if {[llength $available]} { @@ -307,6 +307,97 @@ tcl::namespace::eval punk::lib::check { return [dict create bug $bug bugref f10d91c2d3 description $description level major mitigated $mitigated mitigation $mitigation] } + #pure classifier, separated for testability - facts in, verdict out. + #The bug's signature is a MIXTURE within one switch: the default arm reports its + #single command arm-relative (line 2 of the arm script) while arm 1 reports it + #shifted by (line of the switch command within its containing script - 1), which + #is 3 in the probe layout below. A self-consistent upstream fix of either flavour + #(uniform arm-relative, or uniform container-relative) breaks the signature and + #reports no bug - if upstream instead changes attribution semantics some other + #way, revisit this classifier. + proc tclbug_nestedswitch_tracelines_signature {arm1line defaultline} { + return [expr {$defaultline == 2 && $arm1line == 3}] + } + proc has_tclbug_nestedswitch_tracelines {} { + #Execution-trace line mis-attribution for nested single-block switch arm bodies. + #https://core.tcl-lang.org/tcl/tktview/5d5b1052280c976ea3d4 (reported by punkshell author 2025-11-10) + #For a proc without source-line correlation (e.g dynamically defined - also the regime + #module-loaded punkshell procs trace in), an arm body whose index into the split + #pattern/body list lands on a LITERAL word of the switch command (an option word, --, + #or the block itself) reports enterstep/info-frame lines shifted by (line of the switch + #command within its containing script - 1) - attributed as if the arm body began at the + #switch command's line. Arms whose index lands on a dynamic word or beyond the command's + #word count report correctly arm-relative - so WHICH arms mismark varies with the option + #words used. Verified identical on Tcl 8.6.17 / 8.7a6 / 9.0.3 (2026-07-14). + #Standalone repro/write-up: scriptlib/developer/tcl_switch_traceline_repro.tcl + # + #Behavioural probe (no version gate needed - detection flips automatically when a fixed + #Tcl runtime is in use): a dynamically-defined proc with a nested 'switch -- $c {...}' + #is enterstep-traced once for arm 1 and once for the default arm, and the reported lines + #are matched against the characterized wrong/right signature (see the classifier above). + # + #Followup when upstream fixed (this check starts reporting bug 0 on a new Tcl release): + # - re-verify with scriptlib/developer/tcl_switch_traceline_repro.tcl on that runtime + # - flip the GAP pins in test suite ns/cmdtrace.test + # (cmdtrace_marks_nested_upstream_mismark_GAP and the fixed-canary test there) + # - update the punk::ns::cmdtrace argdoc caveat that cites the ticket + # - note the fixed-in version here + #Consumers: punk::ns::cmdtrace switch-arm line marking accuracy; 'help tcl' warning report. + set pname [namespace current]::Nestedswitch_traceline_probeproc + set lvar [namespace current]::Nestedswitch_traceline_probelines + #the body must be passed via a variable so the probe proc has no source-line + #correlation (the absolute-source regime does not exhibit the mis-attribution) + #inner switch is the 4-word shape (switch -- $string ): per the law, split-list + #body indices 1 and 3 are affected (they land on the literal -- and block words), so the + #middle arm exists purely to push the default arm's body to index 5 - beyond the switch + #command's word count and therefore correctly arm-relative. (A 2-arm probe would put the + #default body at index 3 and BOTH arms would mismark - hiding the signature.) + set probebody { + switch -- [string index $s 0] { + a { + switch -- [string index $s 1] { + 1 { + llength probemark + } + 2 { + llength probeunused + } + default { + llength probemark + } + } + } + default {} + } +} + proc $pname {s} $probebody + set $lvar [list] + set handler [list ::apply [list {pname lvar args} { + set f [::tcl::info::frame -2] + if {[dict exists $f proc] && [dict get $f proc] eq $pname && [dict exists $f cmd]} { + if {[string match "llength probemark*" [dict get $f cmd]]} { + catch {lappend $lvar [dict get $f line]} + } + } + }] $pname $lvar] + set bug 0 + try { + trace add execution $pname enterstep $handler + $pname a1 ;#inner arm 1 + $pname a9 ;#inner default arm + lassign [set $lvar] arm1line defaultline + if {$arm1line ne "" && $defaultline ne ""} { + set bug [tclbug_nestedswitch_tracelines_signature $arm1line $defaultline] + } + } finally { + catch {trace remove execution $pname enterstep $handler} + catch {rename $pname ""} + catch {unset $lvar} + } + set description "Execution traces on a nested single-block switch mis-attribute lines for the arm bodies\nwhose split-list index lands on a literal word of the switch command (options/--/block):\nthose arms report lines as if their body began at the switch command's line, while other\narms report correctly arm-relative. Debug/trace tooling line markers (e.g punk::ns::cmdtrace)\nare wrong for the affected arms - which arms are affected varies with the switch options used." + return [dict create bug $bug bugref 5d5b1052280c976ea3d4 description $description level medium] + } + #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. @@ -9238,7 +9329,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.3 + set version 0.5.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.5.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.8.0.tm similarity index 81% rename from src/vfs/_vfscommon.vfs/modules/punk/ns-0.5.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/ns-0.8.0.tm index b8642dc5..f2aa47d1 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.5.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.8.0.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::ns 0.5.0 +# Application punk::ns 0.8.0 # Meta platform tcl # Meta license # @@ Meta End @@ -51,11 +51,8 @@ tcl::namespace::eval punk::ns { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ns { - #variable ns_current - ##allow presetting - #if {![info exists ::punk::ns::ns_current]} { - # set ns_current :: - #} + #2026-07-14 Agent-Updated: removed a commented-out ns_current presetting block - + #the shell's current-namespace state lives in punk::nav::ns (::punk::nav::ns::ns_current), not here. variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype synopsis @@ -156,6 +153,9 @@ tcl::namespace::eval punk::ns { #for 'weird' namespaces, this uses a generated nested script #It has to run this (probably non byte-compiled?) script twice in some cases #consider coroutine-based alternative? + #2026-07-14 Agent-Generated: note that punk::ns parses p:::x leading-colon-greedy (child literally + #named :x) whereas native 'namespace eval p:::x' resolves to child x - the divergence and the + #no-create/error-propagation contract of nseval_ifexists are pinned in tests ns/nsprimitives.test. proc nseval_ifexists {ns script} { set parts [nsparts $ns] if {[lindex $parts 0] ne ""} { @@ -281,7 +281,10 @@ tcl::namespace::eval punk::ns { } #Note nsjoin,nsjoinall,nsprefix,nstail are string functions that don't care about namespaces in existence. - #Some functions in punk::ns are + #2026-07-14 Agent-Updated: (completed a trailing sentence fragment) Other functions in punk::ns are + #contextual - they resolve relative paths against the caller's namespace (e.g nsexists, nschildren, + #nspath_here_absolute) and/or consult live interp state. + #Behaviour of the string primitives - including the edge cases below - is pinned in tests ns/nsprimitives.test. proc nsjoin {prefix name} { if {[string match ::* $name]} { @@ -293,21 +296,19 @@ tcl::namespace::eval punk::ns { if {"$prefix" eq "::"} { return ::$name } - #if {"$name" eq ""} { - # return $prefix - #} + #Note an empty prefix with a relative name produces an ABSOLUTE path (nsjoin {} x -> ::x). + #An empty name is deliberately not special-cased: #nsjoin ::x::y "" should return ::x::y:: - this is the correct fully qualified form used to call a command that is the empty string return ${prefix}::$name } proc nsjoinall {prefix args} { - #if {![llength $args]} { - # error "usage: nsjoinall prefix relativens \[relativens ...\]" - #} set segments [list $prefix] foreach sub $args { if {[string match ::* $sub]} { if {[string length [concat {*}$segments]]} { - error "nsjoin: won't join non-empty namespace prefix to absolute namespace path '$sub'" + #2026-07-14 Agent-Updated: message previously said 'nsjoin:' (copy-paste wart, + #pin flipped in tests ns/nsprimitives.test nsjoinall_edges) + error "nsjoinall: won't join non-empty namespace prefix to absolute namespace path '$sub'" } } lappend segments $sub @@ -336,15 +337,9 @@ tcl::namespace::eval punk::ns { #nsparts will prefer leading colon (ie greedy on ::) #This is important to support leading colon commands such as :/ # ie ::punk:::jjj:::etc -> :: punk :jjj :etc - proc nsparts1 {nspath} { - set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] - set parts [split $mapped \u0FFF] - #if {[lindex $parts end] eq ""} { - #} - return $parts - } - + #2026-07-14 Agent-Updated: removed the superseded simpler variant nsparts1 (blanket ::::->:: collapse + #before splitting - NOT equivalent to nsparts on colon runs of 5+; divergence was pinned before removal, + #see git history of tests ns/nsprimitives.test). #Memory leak for systems that create and delete a lot of differently names namespaces/commands - review #consider configuration option to disable for large long-running systems? @@ -483,7 +478,7 @@ tcl::namespace::eval punk::ns { #The main difference being collapsing (or ignoring) repeated double-colons #we need to distinguish unprefixed from prefixed ie ::x vs x #There is an apparent inconsistency with nstail ::a:::x being able to return :x - #whereas nsprefix :::a will return just ::a + #whereas nsprefix :::a will return just :: (2026-07-14 Agent-Updated: was documented as ::a - the actual value is :: per tests ns/nsprimitives.test) #This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) #and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval #The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. @@ -491,97 +486,18 @@ tcl::namespace::eval punk::ns { #nsprefix is *somewhat* like 'namespace parent' except that it is string based - ie no requirement for the namespaces to actually exist # - this is an important usecase even if the handling of 'unwise' command names isn't so critical. #nsprefix is more like 'namespace qualifiers' - but can return the global namespace as :: instead of empty string. - proc nsprefix1 {{nspath ""}} { - #normalize the common case of leading :::: and also collapse any internal runs of 4 (there can be no namespace named as empty string - as this is reserved for global ns by Tcl) - - while {[regexp {::::} $nspath]} { - set nspath [string map {:::: ::} $nspath] - } - set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] - if {$rawprefix eq "::"} { - return $rawprefix - } else { - if {[string match *:: $rawprefix]} { - return [string range $rawprefix 0 end-2] - } else { - return $rawprefix - } - #return [string trimright $rawprefix :] - } - } - #deprecated - proc nsprefix_orig {{nspath ""}} { - #normalize the common case of :::: - set nspath [string map {:::: ::} $nspath] - set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] - if {$rawprefix eq "::"} { - return $rawprefix - } else { - if {[string match *:: $rawprefix]} { - return [string range $rawprefix 0 end-2] - } else { - return $rawprefix - } - #return [string trimright $rawprefix :] - } - } - + #2026-07-14 Agent-Updated: removed the superseded variants nsprefix1 and nstail1 and the deprecated + #nsprefix_orig/nstail_orig (all collapse long colon runs before splitting - NOT equivalent to the + #nsparts-based nsprefix/nstail on colon runs of 5+; divergence was pinned before removal, see git + #history of tests ns/nsprimitives.test). nstail1 also had an unshipped '-strict' flag raising an error + #on unpaired-colon segments - a possible future validation feature for nstail if ever needed. + + #string-based tail: returns the last nsparts segment - unlike 'namespace tail' it preserves + #leading/trailing colons in the tail (nstail ::a:::b -> :b) and returns empty for a trailing :: path. proc nstail {nspath} { return [lindex [nsparts_cached $nspath] end] } - #namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing - #review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. - #This is only necessary in the context of requirement to browse namespaces with 'unwisely' named commands - #For most purposes 'namespace tail' is fine. - proc nstail1 {nspath args} { - #normalize the common case of :::: - while {[regexp {::::} $nspath]} { - set nspath [string map {:::: ::} $nspath] - } - #it's unusual - but namespaces *can* have spaced in them. - set mapped [string map {:: \u0FFF} $nspath] - set parts [split $mapped \u0FFF] - - set defaults [list -strict 0] - set opts [dict merge $defaults $args] - set strict [dict get $opts -strict] - - if {$strict} { - foreach p $parts { - if {[string match :* $p]} { - error "nstail unpaired colon ':' in $nspath" - } - } - } - - #e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. - return [lindex $parts end] - } - #deprecated - proc nstail_orig {nspath args} { - #normalize the common case of :::: - set nspath [string map {:::: ::} $nspath] - #it's unusual - but namespaces *can* have spaced in them. - set mapped [string map {:: \u0FFF} $nspath] - set parts [split $mapped \u0FFF] - - set defaults [list -strict 0] - set opts [dict merge $defaults $args] - set strict [dict get $opts -strict] - - if {$strict} { - foreach p $parts { - if {[string match :* $p]} { - error "nstail unpaired colon ':' in $nspath" - } - } - } - - #e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. - return [lindex $parts end] - } - #tcl 8.x has creative writing var weirdness.. tcl 9 is likely to differ proc nsvars {{nsglob "*"}} { @@ -635,10 +551,10 @@ tcl::namespace::eval punk::ns { lappend pats "" } * { - #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed - #lappend pats {[^:]*} - #negative lookahead - #any number of chars not followed by ::, followed by any number of non : + #2026-07-14 Agent-Updated: (was a stale 'should be fixed' note - the fix is in place) + #negative lookahead: any number of chars not followed by ::, followed by any number of non-: + #so * matches within a level INCLUDING a single inner colon (::g*t finds ::got:it) + #but never crosses a :: separator. Pinned in tests ns/nsprimitives.test (globmatchns_pins). lappend pats {(?:.(?!::))*[^:]*} } ** { @@ -658,31 +574,9 @@ tcl::namespace::eval punk::ns { } return "^[join $pats ::]\$" } - #obsolete - proc nsglob_as_re1 {glob} { - #any segment that is not just * must match exactly one segment in the path - set pats [list] - foreach seg [nsparts_cached $glob] { - if {$seg eq ""} { - set seg "" - } - if {$seg eq "*"} { - lappend pats {[^:]*} - } elseif {$seg eq "**"} { - lappend pats {.*} - } else { - #set seg [string map [list . {[.]}] $seg] - set seg [string map {. [.]} $seg] - if {[regexp {[*?]} $seg]} { - set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] - lappend pats "$pat" - } else { - lappend pats "$seg" - } - } - } - return "^[join $pats ::]\$" - } + #2026-07-14 Agent-Updated: removed the obsolete-marked nsglob_as_re1 (pre-lookahead version whose * + #could not match an inner colon). Live nsglob_as_re behaviour is pinned via globmatchns in tests + #ns/nsprimitives.test. proc globmatchns {glob path} { #the total set of namespaces is *generally* reasonably bounded so we could just cache all globs, perhaps with some pretty high limit for sanity.. (a few thousand?) review - memory cost? # Tcl (reportedly https://wiki.tcl-lang.org/page/regexp) only caches 'up to 30'dynamically - but should cache more if more stored. @@ -721,20 +615,27 @@ tcl::namespace::eval punk::ns { } + #2026-07-14 Agent-Updated: filled in the previously empty summary/help fields. + #(the internal recursion option -call-depth-internal parsed by the proc is deliberately undocumented) punk::args::define { @id -id ::punk::ns::nstree_list @cmd -name punk::ns::nstree_list\ -summary\ - ""\ + "List namespaces matching a namespace path glob."\ -help\ - "" + "Return a list of fully qualified namespaces matching the + location glob. Glob chars (* ?) may appear in any path segment. + A segment of ** (or trailing ** on a segment) matches across + multiple namespace levels." @leaders location -type path -optional 0 @opts -subnslist -type list -default {} -help\ - "" + "Remaining glob path segments still to be matched + (internal - used during recursion)." -allbelow -type boolean -default 1 -help\ - "" + "Also return namespaces nested deeper than the matched + glob path (the matched namespaces' subtrees)." @values -min 0 -max 0 } #important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure. @@ -841,32 +742,8 @@ tcl::namespace::eval punk::ns { } set nslist [lsort -unique $nslist] - - if 0 { - set nextglob [lindex $tailparts 0] - if {$nextglob ne "**"} { - set nslist [list] - if {[llength $tailparts]} { - set nsmatches [list] - #lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]::*] - lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] - } else { - set nsmatches $allchildren - } - #return - - foreach ch $nsmatches { - lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] - } - } else { - set nslist [nstree_list $base -subnslist {} -allbelow 1] - } - } - - #foreach ns $nslist { - # puts "== $ns" - #} + #2026-07-14 Agent-Updated: removed an 'if 0' disabled earlier version of the tailparts matching + #(recoverable via git history). set nslist_filtered [list] if {$CALLDEPTH == 0} { #puts "--base: $base" @@ -1130,11 +1007,14 @@ tcl::namespace::eval punk::ns { } proc get_nslist {args} { set known_types [list children commands exported imported aliases procs ensembles ooclasses ooobjects ooprivateobjects ooprivateclasses native coroutines interps zlibstreams] - set defaults [dict create {*}{ + #2026-07-14 Agent-Updated: -types default was inside a braced literal, so it was the literal + #string '$known_types' - any call without -types (e.g bare nslist) errored with a malformed + #'Unrecognised namespace member type: $known_types' message. Fixed to default to all known + #types (pin flipped: tests ns/nslist.test nslist_types_default). + set defaults [dict create {*}{ -match "" - -types $known_types -nsdict "" - }] + } -types $known_types] set opts [dict merge $defaults $args] # -- --- --- --- --- --- --- --- --- --- set fq_glob [dict get $opts -match] @@ -1346,22 +1226,16 @@ tcl::namespace::eval punk::ns { - #set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + #2026-07-14 Agent-Updated: removed per-line commented-out pipedata equivalents of the width calcs below. set lenlist1 [lmap v [list {*}$children1 ""] {string length $v}] set chwidest1 [tcl::mathfunc::max {*}$lenlist1] - #set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] set chwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$children2 ""] {string length $v}]] #wrap the cmd in [list] (just for the width calc) to get a proper length for what will actually be displayed - #set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] set cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {string length [list [lindex $v 1]]}]] - - #set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] set cmdwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$elements2 ""] {string length [list [lindex $v 1]]}]] - #set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] set cmdwidest3 [tcl::mathfunc::max {*}[lmap v [list {*}$elements3 ""] {string length [list [lindex $v 1]]}]] - #set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] set cmdwidest4 [tcl::mathfunc::max {*}[lmap v [list {*}$elements4 ""] {string length [list [lindex $v 1]]}]] set displaylist [list] @@ -1417,6 +1291,12 @@ tcl::namespace::eval punk::ns { if {$cmd ni $commands && $cmd in $aliases } { #ordinary un-masked commandless-alias #(original alias name that has been renamed) + #2026-07-14 Agent-Generated: this red-strike branch and the yellow masked-alias + #branch below appear unreachable from the current get_ns_dicts bucket derivation + #(probed 2026-07-14: an alias overwritten by a same-name proc classifies as proc + #only, and a renamed alias stays a plain als entry - see the fixture-findings + #header of tests ns/nslist.test). Retained pending the planned display rework - + #reassess reachability there before deleting. set c [a+ red bold strike] set prefix "${a}als " set prefix [overtype::right $prefix "-R"] @@ -1542,23 +1422,21 @@ tcl::namespace::eval punk::ns { will display just a basic note: 'Also resolving cmds in namespace paths: '. If -nspathcommands is true, it will also display subtables showing the commands resolvable via any such listed namespaces." - -types + #2026-07-14 Agent-Updated: -types deliberately has no -default - an unsupplied -types must stay + #absent from the parsed opts so get_nslist's own all-types default applies. + -types -help\ + "Restrict display to the given list of namespace member types + e.g {children commands procs aliases ensembles} + (the full set - plus the expanders 'oo' and 'all' - is validated by + punk::ns::get_nslist, which this option is passed through to). + When not supplied, all member types are displayed." @values -min 0 -max -1 glob -multiple 1 -optional 1 -default "*" } proc nslist {args} { set argd [punk::args::parse $args withid ::punk::ns::nslist] lassign [dict values $argd] leaders opts values received solos multis - - #if {[dict exists $args -match]} { - # #review - presumably this is due to get_nslist taking -match? - # error "nslist requires positional argument 'glob' instead of -match option" - #} - #set defaults [dict create {*}{ - # } -match $ns_absolute {*}{ - # -nspathcommands 0 - #}] - #set opts [dict merge $defaults $args] + #2026-07-14 Agent-Updated: removed a commented-out pre-punk::args manual defaults block. # -- --- --- set opt_nspathcommands [dict get $opts -nspathcommands] # -- --- --- @@ -1751,6 +1629,11 @@ tcl::namespace::eval punk::ns { dict set switchblock_cache $patternblock $result return $result } + #2026-07-14 Agent-Generated: the test_switch* procs below are deliberate fixtures for the + #switchblock_info/cmdtrace nested-switch line-attribution work - NOT dead code. They are exercised + #by tests ns/cmdtrace.test (test_switch2/test_switch4/test_switch5) and were used to characterize + #the upstream traceline mismark (core.tcl-lang.org tktview 5d5b1052280c976ea3d4). Do not remove + #while cmdtrace/G-085 work is live. proc test_switch {s} { switch -- $s { x {return x} a - b { @@ -2128,6 +2011,12 @@ y" {return quirkykeyscript} } variable tinfo + variable _cmdtrace_pause 1 ;#gate for the interactive pause in _cmdtrace_leave (cmdtrace -pause option) + #2026-07-14 Agent-Generated: KNOWN NOISE - the cmdtrace machinery (the _cmdtrace_* callbacks and + #_cmdtrace_get_eval_offset*) emits development-style progress output on stdout/stderr as it traces + #('found a switch', per-step lines, testswitch dumps ...). Deliberately left as-is here: output + #discipline (and machine-parseable trace output) is in scope for proposed goal G-085 - clean it up + #there rather than piecemeal. proc _cmdtrace_enter {vname target args} { variable _cmdtrace_disabled if {$_cmdtrace_disabled} return @@ -2212,8 +2101,11 @@ y" {return quirkykeyscript} } } puts stdout $procbody - punk::lib::askuser "paused - hit enter key to continue" - puts stdout "continuing..." + variable _cmdtrace_pause + if {$_cmdtrace_pause} { + punk::lib::askuser "paused - hit enter key to continue" + puts stdout "continuing..." + } } set _cmdtrace_disabled false @@ -2623,12 +2515,27 @@ y" {return quirkykeyscript} are dubious when *not* referencing source file. (inconsistently based on start-of-switch vs start-of-switcharm script) - Possibly an unreported/unacknowleged - bug in Tcl. + Upstream Tcl bug, reported: + https://core.tcl-lang.org/tcl/tktview/5d5b1052280c976ea3d4 + Observed pattern (8.6/8.7/9.0): an arm body of a + nested single-block switch reports lines shifted by + (line of the switch command within its containing + script - 1) exactly when the arm body's index into + the split pattern/body list lands on a literal word + of the switch command itself (options, --, or the + block); arms whose index lands on a dynamic word or + beyond the command's word count report correctly + arm-relative. See tests ns/cmdtrace.test. " @opts -target -type string -multiple 1 -help\ "" + -pause -type boolean -default 1 -help\ + "Pause (wait for enter key) after each traced proc leave + displays its marked-up body. + Set to false for non-interactive/scripted use so the + trace can run unattended and the final marked-up body + report (the return value) can be captured." -- -type none -help\ "end of options indicator" @values -min 1 -max -1 @@ -2651,6 +2558,9 @@ y" {return quirkykeyscript} set argd [punk::args::parse $args -cache 1 withid ::punk::ns::cmdtrace] lassign [dict values $argd] leaders opts values received + variable _cmdtrace_pause + set _cmdtrace_pause [dict get $opts -pause] + set cmdargs [dict get $values arg] set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdargs]] @@ -2693,10 +2603,7 @@ y" {return quirkykeyscript} #we will need to evaluate in the namespace foreach {tgt_cmd ns nscmd} $resolved_targets { puts stderr "tracing target: $tgt_cmd whilst running: $origin $arglist" - - #::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] - #::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] - #::tcl::namespace::eval $ns [list ::trace add execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] + #nseval rather than tcl::namespace::eval - see leading-colon note above nseval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] nseval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] nseval $ns [list ::trace add execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] @@ -2704,9 +2611,7 @@ y" {return quirkykeyscript} try { - #uplevel 1 [list $origin {*}$arglist] set _cmdtrace_disabled false - #::tcl::namespace::eval $origin_ns [list $origin_nscmd {*}$arglist] nseval $origin_ns [list $origin_nscmd {*}$arglist] } trap {} {errMsg errOptions} { set _cmdtrace_disabled true @@ -2716,9 +2621,6 @@ y" {return quirkykeyscript} } finally { set _cmdtrace_disabled true foreach {tgt_cmd ns nscmd} $resolved_targets { - #::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] - #::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] - #::tcl::namespace::eval $ns [list ::trace remove execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] nseval $ns [list ::trace remove execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] nseval $ns [list ::trace remove execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] nseval $ns [list ::trace remove execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] @@ -3182,7 +3084,6 @@ y" {return quirkykeyscript} dict set nspathdict $pathns [dict create] ;#use consistent structure when nspathcommands false } } - #set exportpatterns [nseval $location {::namespace export}] set allexported [list] set matched [list] foreach p $exportpatterns { @@ -3221,7 +3122,6 @@ y" {return quirkykeyscript} } else { set allprocs [tcl::namespace::eval $location {::info procs}] } - #set allprocs [nseval $location {::info procs}] set childtails [lmap v $allchildren {nstail $v}] set allaliases [list] set allnative [list] @@ -3235,7 +3135,8 @@ y" {return quirkykeyscript} set allooprivateclasses [list] set allimported [list] set allundetermined [list] - set interp_aliases [interp aliases ""] + #2026-07-14 Agent-Updated: removed unused assignment 'set interp_aliases [interp aliases ""]' + #(its only consumer was the commented-out per-command alias check below). #use aliases glob - because aliases can be present with or without leading :: #NOTE: alias may not have matching command in the relevant namespace (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases if {$weird_ns} { @@ -3243,7 +3144,6 @@ y" {return quirkykeyscript} } else { set raw_aliases [tcl::namespace::eval $location [list ::punk::ns::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } - #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] foreach a $raw_aliases { if {[string match *:: $a]} { @@ -3584,141 +3484,12 @@ y" {return quirkykeyscript} } return $nsdict_list } - #Must be no ansi when only single arg used. - #review - ansi codes will be very confusing in some scenarios! + #2026-07-14 Agent-Updated: removed the superseded pipeline-based command aliases nscommands1 and + #nscommands2 (user direction 2026-07-14; flagged as removal candidates in the 0.7.0 hygiene pass). + #The plain proc nscommands below is the live implementation (adds weird-namespace handling); + #nscommands1 was broken - it referenced nonexistent commands (nsthis2, inspect at global scope). + #Recoverable via git history. #todo - only output color when requested (how?) or via repltelemetry ? - interp alias {} nscommands2 {} .= ,'ok'@0.= { - #Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x - #inspect -label namespace_current [namespace current] - #inspect -label info_procs [info procs] - - ::set commandns [::namespace current] - ::set commandlist [::list] - #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway - #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed - ::set colors [::list none cyan yellow green] - ::set ci 0 ;#colourindex - ::set do_raw 0 - ::if {[::set posn [::lsearch $searchlist -raw]] >= 0} { - #::set searchlist [::lreplace $searchlist $posn $posn] - ::ledit searchlist $posn $posn - ::set do_raw 1 - } - ::if {![::llength $searchlist]} { - ::lappend searchlist * - } - ::foreach search $searchlist { - ::if {$ci > [::llength $colors]-1} { - ::set ci 0 - } - #by using pipeswitch instead of pipeswitchc - we give the ability* for the switch script block to affect vars in the calling scope - # (*not a desirable feature from a functional point of view - but useful for debugging, and also potentially faster ) - ::if {$ci == 0 || $do_raw} { - ::set col "" - ::set rst "" - } else { - ::set col [a+ [::lindex $colors $ci] bold] - ::set rst [a+] - } - ::incr ci ;#colourindex - #inspect -label search $search - - ::if {![::llength $search]} { - ::set base $commandns - ::set what "*" - } else { - ::if {[::string match ::* $search]} { - ::set base [::punk::ns::nsprefix $search] - ::set what [::punk::ns::nstail $search] - } else { - ::set base $commandns - ::set what $search - } - } - - ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] - #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created - ::if {![::tcl::namespace::exists $base]} { - ::continue - } - - if 0 { - #NOTE - matched commands will return commands from global ns due to 'namespace eval' - also any commands from namespaces in the 'namespace path' list - #We don't simply do info commands ${base}::$what because it misses some oddly named things (JMN 2023 - like what?) - #this was to support weird namespaces with leading/trailing colons - not an important usecase for the cost - ::set matchedcommands [::pipeswitch { - ::pipecase \ - caseresult.= ::list $base $what |,basens/0,g/1> {tcl::namespace::eval $basens [::list ::info commands $g]} - }] - #lappend commandlist {*}[@@ok/result= $matchedcommands] - #need to pull result from matchedcommands dict - #set cmd_tails [@@ok/result= $matchedcommands |> {::lmap v $data {punk::ns::nstail $v}}] - ::set cmd_tails [::lmap v [::dict get $matchedcommands ok result] {::punk::ns::nstail $v}] - ::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] - ::foreach c $cmd_tails { - ::if {$c in $all_ns_tails} { - ::if {$do_raw} { - ::lappend commandlist [::list $c $c] - } else { - ::lappend commandlist [::list $c $col[::list $c]$rst] - } - } - } - } else { - - ::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] - foreach c $all_ns_tails { - ::if {$do_raw} { - ::lappend commandlist [::list $c $c] - } else { - ::lappend commandlist [::list $c $col[::list $c]$rst] - } - } - } - } - ::list ok [::list result $commandlist] - #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) - #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. - } |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} \ - 1.= {expr {[string length [string map [list * "" ? ""] $data]] == [string length $data]}} |> { - #uplevel 1 [list info commands ${input}::*] - info commands ${input}::* - } - - #pipecase1 ns has one or more of glob chars * or ? - pipecase \ - caseresult= $ns |input> { - #uplevel 1 [list info commands ${input}] - info commands ${input} - } - } - } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} >> base: $base what: $what" + #2026-07-14 Agent-Updated: commented out a development trace puts that polluted + #nscommands stdout output on the weird-namespace path (same treatment as the 0.1.1 + #doc-lookup trace-puts cleanup) + #puts ">>> base: $base what: $what" ::set all_ns_commands [nseval_ifexists $base [list apply {{loc what} { set _all [uplevel 1 [list ::tcl::info::commands]] set _matches [list] @@ -5579,11 +5353,11 @@ y" {return quirkykeyscript} 3) ensemble commands - auto-generated unless documented via punk::args (subcommands will show with an indicator if they are explicitly documented or are themselves ensembles) - 4) tcl::oo objects - auto-gnerated unless documented via punk::args + 4) tcl::oo objects - auto-generated unless documented via punk::args 5) dereferencing of aliases to find underlying command (will not work with some renamed aliases) - Note that native commands commands not explicitly documented will + Note that native commands not explicitly documented will generally produce no useful info. For example sqlite3 dbcmd objects could theoretically be documented - but as 'info cmdtype' just shows 'native' they can't (?) be identified as belonging to sqlite3 without @@ -5856,943 +5630,13 @@ y" {return quirkykeyscript} } return "Undocumented command $origin. Type: $origintype" } - - #return [cmdinfo $origin {*}$queryargs] } - #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? - # - as this is interactive generally introspection should be ok at the top level - # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? - #TODO - make obsolete - (replaced by punk::ns::cmdhelp) - #punk::args::define { - # @dynamic - # @id -id ::punk::ns::arginfo - # @cmd -name punk::ns::arginfo\ - # -summary\ - # "Command usage/help."\ - # -help\ - # "Show usage info for a command. - # It supports the following: - # 1) Procedures or builtins for which a punk::args definition has - # been loaded. - # 2) tepam procedures (returns string form only) - # 3) ensemble commands - auto-generated unless documented via punk::args - # (subcommands will show with an indicator if they are - # explicitly documented or are themselves ensembles) - # 4) tcl::oo objects - auto-gnerated unless documented via punk::args - # 5) dereferencing of aliases to find underlying command - # (will not work with some renamed aliases) - - # Note that native commands commands not explicitly documented will - # generally produce no useful info. For example sqlite3 dbcmd objects - # could theoretically be documented - but as 'info cmdtype' just shows - # 'native' they can't (?) be identified as belonging to sqlite3 without - # calling them. arginfo deliberately avoids calling commands to elicit - # usage information as this is inherently risky. (could create a file, - # exit the interp etc) - # " - # -return -type string -default table -choices {string table tableobject} - - - # } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - # -form -default 0 -help\ - # "Ordinal index or name of command form" - # -grepstr -default "" -type list -typesynopsis regex -help\ - # "list consisting of regex, optionally followed by ANSI names for highlighting - # (incomplete - todo)" - # -- -type none -help\ - # "End of options marker - # Use this if the command to view begins with a -" - # @values -min 1 - # commandpath -help\ - # "command (may be alias, ensemble, tcl::oo object, tepam proc etc)" - # subcommand -optional 1 -multiple 1 -default {} -help\ - # "subcommand if commandpath is an ensemble. - # Multiple subcommands can be supplied if ensembles are further nested" - #} - #proc arginfo {args} { - # lassign [dict values [punk::args::parse $args withid ::punk::ns::arginfo]] leaders opts values received - # set nscaller [uplevel 1 [list ::namespace current]] - # #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part - # #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. - # if {![dict exists $received -scheme]} { - # #dict set opts -scheme info - # set scheme_received 0 - # } else { - # set scheme_received 1; #so we know not to override caller's explicit choice - # } - - # set querycommand [dict get $values commandpath] - # set queryargs [dict get $values subcommand] - # set grepstr [dict get $opts -grepstr] - # set opts [dict remove $opts -grepstr] - # #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" - - # #todo - similar to corp? review corp resolution process - # #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented - - # set cinfo [uplevel 1 [list cmdwhich $querycommand]] - # set origin [dict get $cinfo origin] - # set resolved [dict get $cinfo which] - # set cmdtype [dict get $cinfo origintype] - # switch -- $cmdtype { - # script { - # #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block - # set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script - # set origin [lindex $origin 0] - # set queryargs [list {*}$scriptargs {*}$queryargs] - # return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] - # } - # alias { - # #alias to an alias - # return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] - # } - # } - - # #JJJ - # #check for a direct match first - # if {![llength $queryargs]} { - # #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" - # punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: - # if {![punk::args::id_exists $origin] && ![punk::args::id_exists (autodef)$origin]} { - # uplevel 1 [list punk::ns::generate_autodef $origin] - # } - - # if {[punk::args::id_exists (autodef)$origin]} { - # set origin (autodef)$origin - # } - # if {[punk::args::id_exists $origin]} { - # switch -- [dict get $opts -return] { - # string { - # set estyle "basic" - # } - # tableobject { - # set estyle "minimal" - # } - # default { - # set estyle "standard" - # } - # } - # if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { - # if {[dict get $opts -return] eq "tableobject"} { - # return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] - # } else { - # return $parseresult - # } - # } else { - # if {!$scheme_received} { - # dict set opts -scheme info - # } - # return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] - # } - # } - # } - - - # set id $origin - # #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" - # punk::args::update_definitions [list [namespace qualifiers $id]] - - - # #check longest first checking for id matching ::cmd ?subcmd..? - # #REVIEW - this doesn't cater for prefix callable subcommands - # if {[llength $queryargs]} { - # if {[punk::args::id_exists [list $id {*}$queryargs]]} { - # switch -- [dict get $opts -return] { - # string { - # set estyle "basic" - # } - # tableobject { - # set estyle "minimal" - # } - # default { - # set estyle "standard" - # } - # } - # if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { - # if {[dict get $opts -return] eq "tableobject"} { - # return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] - # } else { - # return $parseresult - # } - # } else { - # if {!$scheme_received} { - # dict set opts -scheme info - # } - # return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] - # #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] - # } - # } - # } - - # #didn't find any exact matches - # #traverse from other direction taking prefixes into account - # set specid "" - # if {[punk::args::id_exists $id]} { - # set specid $id - # } elseif {[punk::args::id_exists (autodef)$id]} { - # set specid (autodef)$id - # } - - # if {$specid ne "" && [punk::args::id_exists $specid]} { - # #cycle forward through leading values - # set specargs $queryargs - # if {[llength $queryargs]} { - # #jjj - # set spec [punk::args::get_spec $specid] - # #--------------------------------------------------------------------------- - # set form_names [dict get $spec form_names] - # if {[llength $form_names] == 1} { - # set fid [lindex $form_names 0] - # } else { - # #review - -form only applies to final command? - # # -form must be a list if we have multiple levels of multi-form commands? - # set opt_form [dict get $opts -form] - # if {[string is integer -strict $opt_form]} { - # if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - # error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - # } - # set fid [lindex $form_names $opt_form] - # } else { - # if {$opt_form ni $form_names} { - # error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - # } - # set fid $opt_form - # } - # } - # #--------------------------------------------------------------------------- - # set nextqueryargs [list] ;#build a list of prefix-resolved queryargs - # set queryargs_untested $queryargs - # foreach q $queryargs { - # if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { - # #todo: fix - # set subitems [dict get $spec FORMS $fid LEADER_NAMES] - # if {[llength $subitems]} { - # set next [lindex $subitems 0] - # set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - - # set allchoices [list] - # set choices [punk::args::system::Dict_getdef $arginfo -choices {}] - # set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] - # #maintenance smell - similar/dup of some punk::args logic - review - # #-choiceprefixdenylist ?? - # set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] - # if {[dict exists $choicegroups ""]} { - # dict lappend choicegroups "" {*}$choices - # } else { - # set choicegroups [dict merge [dict create "" $choices] $choicegroups] - # } - # dict for {groupname clist} $choicegroups { - # lappend allchoices {*}$clist - # } - # set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] - # if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { - # break - # } - # lappend nextqueryargs $resolved_q - # lpop queryargs_untested 0 - # #ledit queryargs_untested 0 0 - # if {$resolved_q ne $q} { - # #we have our first difference - recurse with new query args - # #set numvals [expr {[llength $queryargs]+1}] - # #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] - # #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - # if {!$scheme_received} { - # dict unset opts -scheme - # } - # return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] - - # } - # #check if subcommands so far have a custom args def - # #set currentid [list $querycommand {*}$nextqueryargs] - # set currentid [list {*}$specid {*}$nextqueryargs] - # if {[punk::args::id_exists $currentid]} { - # set spec [punk::args::get_spec $currentid] - # #--------------------------------------------------------------------------- - # set form_names [dict get $spec form_names] - # if {[llength $form_names] == 1} { - # set fid [lindex $form_names 0] - # } else { - # #review - -form only applies to final command? - # # -form must be a list if we have multiple levels of multi-form commands? - # set opt_form [dict get $opts -form] - # if {[string is integer -strict $opt_form]} { - # if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - # error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - # } - # set fid [lindex $form_names $opt_form] - # } else { - # if {$opt_form ni $form_names} { - # error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - # } - # set fid $opt_form - # } - # } - # #--------------------------------------------------------------------------- - # set specid $currentid - # set specargs $queryargs_untested - # set nextqueryargs [list] - # } else { - # #We can get no further with custom defs - # #It is possible we have a documented lower level subcommand but missing the intermediate - # #e.g if ::trace remove command was specified and is documented - it will be found above - # #but if ::trace remove is not documented and the query is "::trace remove com" - # #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. - # #that's probably ok. - # break - # } - # } - # } else { - # #review - # break - # } - # } - # } else { - # switch -- [dict get $opts -return] { - # string { - # set estyle "basic" - # } - # tableobject { - # set estyle "minimal" - # } - # default { - # set estyle "standard" - # } - # } - # if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { - # if {[dict get $opts -return] eq "tableobject"} { - # return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] - # } else { - # return $parseresult - # } - # } else { - # if {!$scheme_received} { - # dict set opts -scheme info - # } - # return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] - # #return [uplevel 1 [list punk::args::usage {*}$opts $id]] - # } - # } - # #puts "--->origin $specid queryargs: $specargs" - # set origin $specid - # set queryargs $specargs - # } - - # if {[string match "(autodef)*" $origin]} { - # #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) - # set origin [string range $origin [string length (autodef)] end] - # set resolved $origin - # } - - # set autoid "" - # switch -- $cmdtype { - # object { - # #class is also an object - # #todo -mixins etc etc - # set class [info object class $origin] - # #the call: info object methods -all - # # seems to do the right thing as far as hiding unexported methods, and showing things like destroy - # # - which don't seem to be otherwise easily introspectable - # set public_methods [info object methods $origin -all] - # #set class_methods [info class methods $class] - # #set object_methods [info object methods $origin] - - # if {[llength $queryargs]} { - # set c1 [lindex $queryargs 0] - # if {$c1 in $public_methods} { - # switch -- $c1 { - # new { - # set constructorinfo [info class constructor $origin] - # set arglist [lindex $constructorinfo 0] - # set argdef [punk::lib::tstr -return string { - # @id -id "(autodef)${$origin} new" - # @cmd -name "${$origin} new"\ - # -summary\ - # "Create new object instance."\ - # -help\ - # "create object with autogenerated command name. - # Arguments are passed to the constructor." - # @values - # }] - # set i 0 - # foreach a $arglist { - # if {[llength $a] == 1} { - # if {$i == [llength $arglist]-1 && $a eq "args"} { - # #'args' is only special if last - # append argdef \n "args -optional 1 -multiple 1" - # } else { - # append argdef \n "$a" - # } - # } else { - # append argdef \n "[lindex $a 0] -default [lindex $a 1]" - # } - # incr i - # } - # punk::args::define $argdef - # set queryargs_remaining [lrange $queryargs 1 end] - # switch -- [dict get $opts -return] { - # string { - # set estyle "basic" - # } - # tableobject { - # set estyle "minimal" - # } - # default { - # set estyle "standard" - # } - # } - # if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { - # if {[dict get $opts -return] eq "tableobject"} { - # return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] - # } else { - # return $parseresult - # } - # } else { - # if {!$scheme_received} { - # dict set opts -scheme info - # } - # return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] - # #return [punk::args::usage {*}$opts "(autodef)$origin new"] - # } - # } - # create { - # set constructorinfo [info class constructor $origin] - # set arglist [lindex $constructorinfo 0] - # set argdef [punk::lib::tstr -return string { - # @id -id "(autodef)${$origin} create" - # @cmd -name "${$origin} create"\ - # -summary\ - # "Create new object instance with specified command name."\ - # -help\ - # "create object with specified command name. - # Arguments following objectName are passed to the constructor." - # @values -min 1 - # objectName -type string -help\ - # "possibly namespaced name for object instance command" - # }] - # set i 0 - # foreach a $arglist { - # if {[llength $a] == 1} { - # if {$i == [llength $arglist]-1 && $a eq "args"} { - # #'args' is only special if last - # append argdef \n "args -optional 1 -multiple 1" - # } else { - # append argdef \n "$a" - # } - # } else { - # append argdef \n "[lindex $a 0] -default [lindex $a 1]" - # } - # incr i - # } - # punk::args::define $argdef - # set queryargs_remaining [lrange $queryargs 1 end] - # switch -- [dict get $opts -return] { - # string { - # set estyle "basic" - # } - # tableobject { - # set estyle "minimal" - # } - # default { - # set estyle "standard" - # } - # } - # if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { - # if {[dict get $opts -return] eq "tableobject"} { - # return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] - # } else { - # return $parseresult - # } - # } else { - # if {!$scheme_received} { - # dict set opts -scheme info - # } - # return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] - # #return [punk::args::usage {*}$opts "(autodef)$origin create"] - # } - # } - # destroy { - # #review - generally no doc - # # but we may want notes about a specific destructor - # set argdef [punk::lib::tstr -return string { - # @id -id "(autodef)${$origin} destroy" - # @cmd -name "destroy"\ - # -summary\ - # "delete object instance."\ - # -help\ - # "delete object, calling destructor if any. - # destroy accepts no arguments." - # @values -min 0 -max 0 - # }] - # punk::args::define $argdef - # set queryargs_remaining [lrange $queryargs 1 end] - # switch -- [dict get $opts -return] { - # string { - # set estyle "basic" - # } - # tableobject { - # set estyle "minimal" - # } - # default { - # set estyle "standard" - # } - # } - # if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { - # if {[dict get $opts -return] eq "tableobject"} { - # return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] - # } else { - # return $parseresult - # } - # } else { - # if {!$scheme_received} { - # dict set opts -scheme info - # } - # return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] - # #return [punk::args::usage {*}$opts "(autodef)$origin destroy"] - # } - # } - # default { - # #use info object call to resolve callchain - # #we assume the first impl is the topmost in the callchain - # # and its call signature is therefore the one we are interested in - REVIEW - # # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? - # set implementations [::info object call $origin $c1] - # #result documented as list of 4 element lists - # #set callinfo [lindex $implementations 0] - # set oodef "" - # foreach impl $implementations { - # lassign $impl generaltype mname location methodtype - # switch -- $generaltype { - # method - private { - # #objects being dynamic systems - we should always reinspect. - # #Don't use the cached (autodef) def - # #If there is a custom def override - use it (should really be -dynamic - but we don't check) - # if {$location eq "object"} { - # set idcustom "$origin $c1" - # #set id "[string trimleft $origin :] $c1" ;# " " - # if {[info commands ::punk::args::id_exists] ne ""} { - # if {[punk::args::id_exists $idcustom]} { - # return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] - # } - # } - # set oodef [::info object definition $origin $c1] - # } else { - # #set id "[string trimleft $location :] $c1" ;# " " - # set idcustom "$location $c1" - # if {[info commands ::punk::args::id_exists] ne ""} { - # if {[punk::args::id_exists $idcustom]} { - # return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] - # } - # } - # set oodef [::info class definition $location $c1] - # } - # break - # } - # filter { - # } - # unknown { - # } - # } - # } - # if {$oodef ne ""} { - # set autoid "(autodef)$location $c1" - # set arglist [lindex $oodef 0] - # set argdef [punk::lib::tstr -return string { - # @id -id "${$autoid}" - # @cmd -name "${$location} ${$c1}" -help\ - # "(autogenerated by arginfo) - # arglist:${$arglist}" - # @values - # }] - # set i 0 - # #for 9.1+ can use -integer - # foreach a $arglist { - # switch -- [llength $a] { - # 1 { - # if {$i == [llength $arglist]-1 && $a eq "args"} { - # #'args' is only special if last - # append argdef \n "args -optional 1 -multiple 1" - # } else { - # append argdef \n "$a" - # } - # } - # 2 { - # append argdef \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" - # } - # default { - # error "punk::ns::arginfo unexpected oo argument signature '$arglist'\noodef:$oodef\nimplementations:$implementations" - # } - # } - # incr i - # } - # punk::args::define $argdef - # return [punk::args::usage {*}$opts $autoid] - # } else { - # return "unable to resolve $origin method $c1" - # } - - # } - # } - # } - # } - # set choicelabeldict [dict create] - # set choiceinfodict [dict create] - # foreach cmd $public_methods { - # switch -- $cmd { - # new - create - destroy { - # #todo - # } - # default { - # set implementations [::info object call $origin $cmd] - # set def "" - # foreach impl $implementations { - # lassign $impl generaltype mname location methodtype - # switch -- $generaltype { - # method - private { - # if {$location eq "object" || $location eq $origin} { - # #set id "[string trimleft $origin :] $cmd" ;# " " - # set id "$origin $cmd" - # dict set choiceinfodict $cmd {{doctype objectmethod}} - # } elseif {$location eq $class} { - # set id "$class $cmd" - # dict set choiceinfodict $cmd {{doctype classmethod}} - # } else { - # #set id "[string trimleft $location :] $cmd" ;# " " - # set id "$location $cmd" - # if {[string match "core method:*" $methodtype]} { - # dict lappend choiceinfodict $cmd {doctype coremethod} - # } else { - # dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] - # } - # } - # if {[punk::args::id_exists $id]} { - # #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" - # dict lappend choiceinfodict $cmd {doctype punkargs} - # dict lappend choiceinfodict $cmd [list subhelp {*}$id] - # } - # break - # } - # filter { - # } - # unknown { - # dict set choiceinfodict $cmd {{doctype unknown}} - # } - # } - # } - # } - # } - # } - - # set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review - # #puts stderr "--->$vline" - # set autoid "(autodef)$origin" - # set argdef [punk::lib::tstr -return string { - # @id -id ${$autoid} - # @cmd -name "Object: ${$origin}" -help\ - # "Instance of class: ${$class} (info autogenerated)" - # @leaders -min 1 - # }] - # append argdef \n $vline - # punk::args::define $argdef - - # } - # privateObject { - # return "Command is a privateObject - no info currently available" - # } - # privateClass { - # return "Command is a privateClass - no info currently available" - # } - # interp { - # #todo - # } - # script { - # #todo - # } - # ensemble { - # #review - # #todo - check -unknown - # #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. - # #presumably -choiceprefix should be zero in that case?? - - # set ensembleinfo [namespace ensemble configure $origin] - # set parameters [dict get $ensembleinfo -parameters] - # set prefixes [dict get $ensembleinfo -prefixes] - # set map [dict get $ensembleinfo -map] - # set ns [dict get $ensembleinfo -namespace] - - # #review - we can have a combination of commands from -map as well as those exported from -namespace - # # if and only if -subcommands is specified - - # set subcommand_dict [dict create] - # set commands [list] - # set nscommands [list] - # if {[llength [dict get $ensembleinfo -subcommands]]} { - # #set exportspecs [namespace eval $ns {namespace export}] - # #foreach pat $exportspecs { - # # lappend nscommands {*}[info commands ${ns}::$pat] - # #} - # #when using -subcommands, even unexported commands are available - # set nscommands [info commands ${ns}::*] - # foreach sub [dict get $ensembleinfo -subcommands] { - # if {[dict exists $map $sub]} { - # #-map takes precence over same name exported from -namespace - # dict set subcommand_dict $sub [dict get $map $sub] - # } elseif {"${ns}::$sub" in $nscommands} { - # dict set subcommand_dict $sub ${ns}::$sub - # } else { - # #subcommand probably supplied via -unknown handler? - # dict set subcommand_dict $sub "" - # } - # } - # } else { - # if {[dict size $map]} { - # set subcommand_dict $map - # } else { - # set exportspecs [namespace eval $ns {namespace export}] - # foreach pat $exportspecs { - # lappend nscommands {*}[info commands ${ns}::$pat] - # } - # foreach fqc $nscommands { - # dict set subcommand_dict [namespace tail $fqc] $fqc - # } - # } - # } - - - # set subcommands [lsort [dict keys $subcommand_dict]] - # if {[llength $queryargs]} { - # set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand - # if {$posn_subcommand > 0} { - # set params [lrange $queryargs 0 $posn_subcommand-1] - # set remaining_queryargs [lrange $queryargs $posn_subcommand end] - # } else { - # set params [list] - # set remaining_queryargs $queryargs - # } - # if {[llength $remaining_queryargs]} { - # if {$prefixes} { - # set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] - # } else { - # set match [lindex $remaining_queryargs 0] - # } - # if {$match in $subcommands} { - # set subcmd [dict get $subcommand_dict $match] - # #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - # if {!$scheme_received} { - # dict unset opts -scheme - # } - # #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] - # #use tailcall so %caller% is reported properly in error msg - # tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - # } - # } - # } - - # #todo - synopsis? - # set choicelabeldict [dict create] - - # set choiceinfodict [dict create] - - # dict for {sub subwhat} $subcommand_dict { - # if {[llength $subwhat] > 1} { - # #TODO - resolve using cmdinfo? - # puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" - # } - # set targetfirstword [lindex $subwhat 0] - # set targetinfo [cmdwhich $targetfirstword] - # set targetorigin [dict get $targetinfo origin] - # set targetcmdtype [dict get $targetinfo origintype] - # set nstarget [nsprefix $targetorigin] - - # dict lappend choiceinfodict $sub [list doctype $targetcmdtype] - - # if {[punk::args::id_exists [list $origin $sub]]} { - # dict lappend choiceinfodict $sub {doctype punkargs} - # dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] - # } elseif {[punk::args::id_exists $targetorigin]} { - # dict lappend choiceinfodict $sub {doctype punkargs} - # dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] - # } else { - # #puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" - # } - - # } - - # set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] - # set autoid "(autodef)$origin" - # puts "ENSEMBLE auto def $autoid (arginfo)" - # set argdef [punk::lib::tstr -return string { - # @id -id ${$autoid} - # @cmd -help\ - # "(autogenerated by arginfo) - # ensemble: ${$origin}" - # }] - # if {[llength $parameters] == 0} { - # append argdef \n "@leaders -min 1" - # } else { - # append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" - # foreach p $parameters { - # append argdef \n "$p -type string -help { (leading ensemble parameter)}" - # } - # } - # append argdef \n "@values -unnamed true" - # append argdef \n $vline - # punk::args::define $argdef - # } - # } - - # #if {$autoid ne ""} { - # # return [punk::args::usage {*}$opts $autoid] - # #} - - - # #check ensemble before testing punk::arg::id_exists - # #we want to recalculate ensemble usage info in case ensemble has been modified - - # if {$autoid ne ""} { - # switch -- [dict get $opts -return] { - # string { - # set estyle "basic" - # } - # tableobject { - # set estyle "minimal" - # } - # default { - # set estyle "standard" - # } - # } - # if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { - # # parsing error e.g Bad number of leading values - # #override -scheme in opts with -scheme error - # if {[dict get $opts -return] eq "tableobject"} { - # return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] - # } else { - # return $parseresult - # } - # } else { - # #show usage - with goodargs marked - # #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] - # if {!$scheme_received} { - # dict set opts -scheme info - # } - # return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] - # } - # #return [punk::args::usage {*}$opts $autoid] - # } - - # #check for tepam help - # if {[info exists ::tepam::ProcedureList]} { - # if {$origin in $::tepam::ProcedureList} { - # return [tepam::ProcedureHelp $origin 1] ;#use 1 to return rather than emit to stdout - # } else { - # #handle any tepam functions that don't eat their own dogfood but have help variables - # #e.g tepam::procedure, tepam::argument_dialogbox - # #Rather than hardcode these - we'll guess that any added will use the same scheme.. - # if {[namespace qualifiers $origin] eq "::tepam"} { - # set func [namespace tail $origin] - # #tepam XXXHelp vars don't exactly match procedure names :/ - # if {[info exists ::tepam::${func}Help]} { - # return [set ::tepam::${func}Help] - # } else { - # set f2 [string totitle $func] - # if {[info exists ::tepam::${f2}Help]} { - # return [set ::tepam::${f2}Help] - # } - # #e.g argument_dialogbox -> ArgumentDialogboxHelp - # set parts [split $func _] - # set uparts [lmap p $parts {string totitle $p}] - # set f3 [join [list {*}$uparts Help] ""] - # if {[info exists ::tepam::${f3}]} { - # return [set ::tepam::${f3}] - # } - # } - # } - # } - # } - - # set origin_ns [nsprefix $origin] - # set parts [nsparts_cached $origin_ns] - # set weird_ns 0 - # if {[lsearch $parts :*] >=0} { - # set weird_ns 1 - # } - # if {$weird_ns} { - # set argl {} - # set tail [nstail $origin] - # set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] - # if {$cmdtype eq "proc"} { - # foreach a [nseval_ifexists $origin_ns [list info args $tail]] { - # if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { - # lappend a $def - # } - # lappend argl $a - # } - # } - # } else { - # set cmdtype [punk::ns::cmdtype $origin] - # if {$cmdtype eq "proc"} { - # set argl {} - # set infoargs [info args $origin] - # foreach a $infoargs { - # if {[info default $origin $a def]} { - # lappend a $def - # } - # lappend argl $a - # } - # } - # } - - # if {[llength $queryargs]} { - # #todo - something better ? - # switch -- [dict get $opts -return] { - # string { - # set estyle "basic" - # } - # tableobject { - # set estyle "minimal" - # } - # default { - # set estyle "standard" - # } - # } - - # if {[punk::args::id_exists $origin]} { - # if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { - # if {[dict get $opts -return] eq "tableobject"} { - # return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] - # } else { - # return $parseresult - # } - # } else { - # #show usage - with goodargs marked - # if {!$scheme_received} { - # dict set opts -scheme info - # } - # return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] - # } - # } - # set msg "Undocumented or nonexistant command $origin $queryargs" - # append msg \n "$origin Type: $cmdtype" - # } else { - # if {$cmdtype eq "proc"} { - # set msg "Undocumented proc $origin" - # append msg \n "No argument processor detected" - # append msg \n "function signature: $resolved $argl" - # } else { - # set msg "Undocumented command $origin. Type: $cmdtype" - # } - # } - # if {[llength $grepstr] != 0} { - # if {[llength $grepstr] == 1} { - # return [punk::ansi::grepstr -no-linenumbers -highlight red [lindex $grepstr 0] $msg] - # } else { - # return [punk::ansi::grepstr -no-linenumbers -highlight [lrange $grepstr 1 end] [lindex $grepstr 0] $msg] - # } - # } - # return $msg - #} + #2026-07-14 Agent-Updated: removed the fully commented-out predecessor help command 'arginfo' + #(punk::args::define + proc arginfo, ~930 lines) - superseded by punk::ns::cmdhelp above, which the + #block's own header marked as its replacement. Recoverable via git history. #todo - package up as navns namespace eval argdoc { @@ -6864,7 +5708,9 @@ y" {return quirkykeyscript} List: proc - but a syntax highlighter may return a string that is not a Tcl list. - The 'basic' highlighter " + The 'basic' highlighter colours comments and + bracket/brace characters only - it is not a full + Tcl syntax highlighter." @values -min 1 -max -1 commandname -type string -typesynopsis ${$I}procname${$NI}|${$I}alias${$NI} -help\ "May be either the fully qualified path for the command, @@ -6894,14 +5740,6 @@ y" {return quirkykeyscript} #we want to handle edge cases of commands such as "" or :x #various builtins such as 'namespace which' won't work - #if {[string match ::* $path]} { - # set targetns [nsprefix $path] - # set name [nstail $path] - #} else { - # set thispath [uplevel 1 [list ::nsthis $path]] - # set targetns [nsprefix $thispath] - # set name [nstail $thispath] - #} set cinfo [uplevel 1 [list punk::ns::cmdwhich $path]] set origin [dict get $cinfo origin] set resolved [dict get $cinfo which] @@ -6916,9 +5754,6 @@ y" {return quirkykeyscript} error "no such namespace $targetns" } - #set origin [nseval $targetns [list ::namespace origin $name]] - #set resolved [nseval $targetns [list ::namespace which $name]] - #A renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! #set iproc [info procs $origin] ;#This will find empty-string command as ::ns:: but miss finding proc ":x" as ::ns:::x set iproc [nsjoin $targetns [nseval $targetns [list ::info procs $name]]] @@ -6998,37 +5833,8 @@ y" {return quirkykeyscript} set argl {} set argnames [nseval $targetns [list ::info args $name]] foreach a $argnames { - #if {[info default $origin $a defvar]} { - # lappend a $defvar - #} - - #string map is risky for strange values of $a - #set result [nseval $targetns [string map [list %n% $name %a% $a] { - # #qualify all command names when running in arbitrary namespace - # ::if {[::info default "%n%" "%a%" punk_ns_corp_defvar]} { - # #::return [::list default [::tcl::string::map [::list {"} {\"} \[ {\[]} \] {\]} ] $punk_ns_corp_defvar]][::unset punk_ns_corp_defvar] ;#keep the targetns tidy - # ::return [::list default $punk_ns_corp_defvar][::unset punk_ns_corp_defvar] ;#keep the targetns tidy - # } else { - # ::return [::list none] - # } - #}]] - - #this very odd construct is to avoid using the namespace argument of apply. (handling of *weird/inadvisable* namespaces) - #we use an uplevel from within the apply which runs in the global namespace, (but called via nseval from within targetns) and a result var for 'info default' in the current punk::ns namespace. - #set result [nseval $targetns [list apply [list {procname argname} { - # set has_default [uplevel 1 [list info default $procname $argname ::punk::ns::corp_defvar]] - # if {$has_default} { - # set answer [list default $::punk::ns::corp_defvar] - # } else { - # set answer [list none] - # } - # unset ::punk::ns::corp_defvar - # return $answer - #} ] $name $a]] - #if {[lindex $result 0] eq "default"} { - # lappend a [lindex $result 1] - #} - + #2026-07-14 Agent-Updated: removed two commented-out earlier default-retrieval experiments - + #info_default carries the explanation of the odd apply/uplevel construct (weird-namespace safe). set default_info [info_default $targetns $name $a] if {[dict get $default_info exists]} { lappend a [dict get $default_info default] @@ -7186,17 +5992,8 @@ y" {return quirkykeyscript} } - #review ??? - proc ns_relative_to_location {name} { - if {[string match ::* $name]} { - error "ns_relative_to_location accepts a relative namespace name only ie one without leading ::" - } - - } - proc ns_absolute_to_location {name} { - - } - + #2026-07-14 Agent-Updated: removed the never-implemented stub procs ns_relative_to_location and + #ns_absolute_to_location (empty bodies marked '#review ???', no callers in the repo). tcl::namespace::eval internal { @@ -7256,12 +6053,8 @@ y" {return quirkykeyscript} return [list runopts $runopts cmdargs $cmdargs] } - proc _pkguse_vars {varnames} { - #review - obsolete? - while {"pkguse_vars_[incr n]" in $varnames} {} - #return [concat $varnames pkguse_vars_$n] - return [list {*}$varnames pkguse_vars_$n] - } + #2026-07-14 Agent-Updated: removed the obsolete-marked helper _pkguse_vars (no callers - pkguse + #uses an equivalent inline collision-avoidance loop in its capture apply). proc tracehandler_nowrite {args} { error "readonly in use block" } @@ -7566,7 +6359,6 @@ y" {return quirkykeyscript} } return $out } - #interp alias "" use "" punk::ns::pkguse punk::args::define { @id -id ::punk::ns::nsimport_noclobber @@ -7696,8 +6488,6 @@ y" {return quirkykeyscript} return $all_imported } - #todo - use ns::nsimport_noclobber instead ? - interp alias {} nsthis {} punk::ns::nspath_here_absolute interp alias {} nsorigin {} apply {ns {namespace origin [uplevel 1 ::punk::ns::nspath_here_absolute $ns]} ::} interp alias {} nsvars {} punk::ns::nsvars @@ -7761,6 +6551,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.5.0 + set version 0.8.0 }] -return \ No newline at end of file +return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.2.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.1.tm rename to src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.2.tm index 84c5867c..f63942fa 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.5.2.tm @@ -582,7 +582,12 @@ proc repl::start {args} { interp eval code { namespace eval ::punk::repl::codethread {} set ::punk::repl::codethread::is_running 1 - namespace eval ::punk::nav::ns::ns_current {} + #2026-07-14 Agent-Updated: this previously namespace-eval'd the full + #ns_current VARIABLE name, creating a stray namespace of that name in + #every code interp (visible as a phantom child in n/ listings of the + #nav namespace). Only the parent namespace needs to exist for the + #variable set below. Guarded by tests repl/nscurrent.test. + namespace eval ::punk::nav::ns {} set ::punk::nav::ns::ns_current %ns1% } }] @@ -4525,7 +4530,7 @@ namespace eval ::punk::args::register { package provide punk::repl [namespace eval punk::repl { variable version - set version 0.5.1 + set version 0.5.2 }] #repl::start $program_read_stdin_pipe