From d6f9d3968e82b5ddb52dec58b37c22587d256af8 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 11 Jun 2025 01:24:56 +1000 Subject: [PATCH] punk::args support for flag aliases of form -alias1|-alias2|-optionname --- src/modules/punk/args-999999.0a1.0.tm | 421 +++++++++++++----- src/modules/punk/args-buildversion.txt | 2 +- src/modules/punk/args/tclcore-999999.0a1.0.tm | 6 +- src/modules/punk/args/tzint-999999.0a1.0.tm | 307 +++++++++++++ src/modules/punk/args/tzint-buildversion.txt | 3 + .../args-0.1.5_testsuites/args/synopsis.test | 4 +- 6 files changed, 621 insertions(+), 122 deletions(-) create mode 100644 src/modules/punk/args/tzint-999999.0a1.0.tm create mode 100644 src/modules/punk/args/tzint-buildversion.txt diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index b22941b4..4a639d0a 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -1632,9 +1632,9 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - + -solo - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - + -minsize - -maxsize - -nocase - -multiple - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - -regexprepass - -regexprefail - -regexprefailmsg { @@ -1642,6 +1642,15 @@ tcl::namespace::eval punk::args { #review -solo 1 vs -type none ? conflicting values? tcl::dict::set spec_merged $spec $specval } + -default { + tcl::dict::set spec_merged -default $specval + if {![dict exists $argdef_values -optional]} { + tcl::dict::set spec_merged -optional 1 + } + } + -optional { + tcl::dict::set spec_merged -optional $specval + } -ensembleparameter { #review - only leaders? tcl::dict::set spec_merged $spec $specval @@ -1978,6 +1987,7 @@ tcl::namespace::eval punk::args { set patterns [list *] } dict for {k v} $opts { + #set fullk [tcl::prefix::match -error "" {-return -form -types -antiglobs -override} $k] switch -- $k { -return - -form - -types - -antiglobs - -override {} default { @@ -2111,10 +2121,10 @@ tcl::namespace::eval punk::args { if {[dict get $argspec -ARGTYPE] eq $tp} { set argspec [dict remove $argspec -ARGTYPE] if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] } else { - append result \n "$m $argspec" + append result \n "\"$m\" $argspec" dict set resultdict $m $argspec } } @@ -2173,10 +2183,10 @@ tcl::namespace::eval punk::args { if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { set argspec [dict remove $argspec -ARGTYPE] if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] } else { - append result \n "$m $argspec" + append result \n "\"$m\" $argspec" dict set resultdict $m $argspec } } @@ -3097,32 +3107,59 @@ tcl::namespace::eval punk::args { set opt_names [list] set opt_names_display [list] + set lookup_optset [dict create] if {[llength [dict get $form_dict OPT_NAMES]]} { + set all_opts [list] + foreach optset [dict get $form_dict OPT_NAMES] { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach o $optmembers { + dict set lookup_optset $o $optset + #goodargs + } + } + set full_goodargs [list] + #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname + #map -realname to full argname + foreach g $goodargs { + if {[string match -* $g] && [dict exists $lookup_optset $g]} { + lappend full_goodargs [dict get $lookup_optset $g] + } else { + lappend full_goodargs $g + } + } + set goodargs $full_goodargs if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set trie [punk::trie::trieclass new {*}$all_opts --] set idents [dict get [$trie shortest_idents ""] scanned] #todo - check opt_prefixdeny $trie destroy - foreach c [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $c] + foreach optset [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $optset] if {[dict get $arginfo -prefix]} { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] + set opt_members [split $optset |] + set odisplay [list] + foreach opt $opt_members { + set id [dict get $idents $opt] + #REVIEW + if {$id eq $opt} { + set prefix $opt + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $opt 0 $idlen-1] + set tail [string range $opt $idlen end] + } + lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + lappend opt_names_display [join $odisplay |] } else { - lappend opt_names_display $c + lappend opt_names_display $optset } #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c + lappend opt_names $optset } } else { set opt_names [dict get $form_dict OPT_NAMES] @@ -4047,7 +4084,12 @@ tcl::namespace::eval punk::args { #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc if {$VAL_MIN eq ""} { set valmin 0 - set VAL_MIN 0 + #set VAL_MIN 0 + foreach v $VAL_NAMES { + if {[dict exists $ARG_INFO $v -optional] && ![dict get $ARG_INFO $v -optional]} { + incr valmin + } + } } else { set valmin $VAL_MIN } @@ -4058,27 +4100,37 @@ tcl::namespace::eval punk::args { set optnames [lsearch -all -inline $argnames -*] set ridx 0 set rawargs_copy $rawargs + set remaining_rawargs $rawargs set leader_posn_name "" set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) set is_multiple 0 ;#last leader may be multi + #consider for example: LEADER_NAMES {"k v" "a b c" x} + #(i.e strides of 2 3 and 1) + #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 + set named_leader_args_max 0 + foreach ln $LEADER_NAMES { + incr named_leader_args_max [llength $ln] + } + set nameidx 0 if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { + for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { + set r [lindex $rawargs $ridx] if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { break } - if {$ridx == [llength $LEADER_NAMES]-1} { + if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] + set leader_posn_name [lindex $LEADER_NAMES $nameidx] if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { set is_multiple 1 } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { + } elseif {$ridx > $named_leader_args_max-1} { #beyond names - retain name if -multiple was true if {!$is_multiple} { set leader_posn_name "" } } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string } if {$r eq "--"} { #review end of opts marker: '--' can't be a leader (but can be a value) @@ -4092,13 +4144,20 @@ tcl::namespace::eval punk::args { #flaglike matches a known flag - don't treat as leader break } - #if {![string match -* [lindex $argnames $ridx]]} {} if {$leader_posn_name ne ""} { + #false alarm #there is a named leading positional for this position #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } dict incr leader_posn_names_assigned $leader_posn_name - incr ridx + #incr ridx continue } else { break @@ -4107,6 +4166,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { + set stridelength [llength $leader_posn_name] if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader @@ -4116,32 +4176,64 @@ tcl::namespace::eval punk::args { #review - option to process in this manner? #first check if the optional leader value is a match for a choice ? #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $remaining_rawargs 0]] # if {$vmatch ne ""} { # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] + # lappend pre_values [lpop remaining_rawargs 0] # incr ridx # continue # } #} + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } - #check if enough rawargs to fill any required values - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { + #check if enough remaining_rawargs to fill any required values + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name } + + #leadername may be a 'stride' of arbitrary length (e.g {"key val"} or {"key val etc"}) + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name } else { #required if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it break } + + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values + #we still need to check if enough values for the leader itself + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill *required* leader + break + } + + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -4151,29 +4243,30 @@ tcl::namespace::eval punk::args { if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { break } else { - if {$VAL_MIN ne ""} { - if {[llength $rawargs] > $VAL_MIN} { - lappend pre_values [lpop rawargs 0] + if {$valmin > 0} { + if {[llength $remaining_rawargs] -1 >= $valmin} { + lappend pre_values [lpop remaining_rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } else { break } } else { - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop remaining_rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } } else { #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop remaining_rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { + #review - if is_multiple, keep going if enough remaining_rawargs for values? break } } - incr ridx + #incr ridx } ;# end foreach r $rawargs_copy } @@ -4199,35 +4292,44 @@ tcl::namespace::eval punk::args { } #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals + #assert - remaining_rawargs has been reduced by leading positionals set opts [dict create] ;#don't set to OPT_DEFAULTS here + set all_opts [list] + set lookup_optset [dict create] + foreach optset $OPT_NAMES { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach opt $optmembers { + dict set lookup_optset $opt $optset + } + } set leaders [list] set arglist {} set post_values {} #valmin, valmax - #puts stderr "rawargs: $rawargs" + #puts stderr "remaining_rawargs: $remaining_rawargs" #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { + if {[lsearch $remaining_rawargs -*] >= 0} { #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] + set maxidx [expr {[llength $remaining_rawargs] -1}] if {$valmax == -1} { - set vals_total_possible [llength $rawargs] + set vals_total_possible [llength $remaining_rawargs] set vals_remaining_possible $vals_total_possible } else { set vals_total_possible $valmax set vals_remaining_possible $vals_total_possible } for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] + set a [lindex $remaining_rawargs $i] + set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] #lowest valmin is 0 if {$remaining_args_including_this <= $valmin} { # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] break } @@ -4239,26 +4341,38 @@ tcl::namespace::eval punk::args { #finite max number of vals if {$remaining_args_including_this == $valmax} { #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] } else { #assume it's an end-of-options marker lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] + set arglist [lrange $remaining_rawargs 0 $i] + set post_values [lrange $remaining_rawargs $i+1 end] } } else { #unlimited number of post_values accepted #treat this as eopts - we don't care if remainder look like options or not lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] + set arglist [lrange $remaining_rawargs 0 $i] + set post_values [lrange $remaining_rawargs $i+1 end] } break } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + set opt [tcl::prefix match -error "" [list {*}$all_opts --] $a] + if {$opt eq "--"} {set opt ""} + if {[dict exists $lookup_optset $opt]} { + set fullopt [dict get $lookup_optset $opt] + } else { + set fullopt "" + } if {$fullopt ne ""} { - if {![tcl::dict::get $argstate $fullopt -prefix] && $a ne $fullopt} { + #e.g when fullopt eq -fg|-foreground + #-fg is an alias , -foreground is the 'api' value for the result dict + #$fullopt remains as the key in the spec + set optmembers [split $fullopt |] + set api_opt [lindex $optmembers end] + + if {![tcl::dict::get $argstate $fullopt -prefix] && $a ni $optmembers} { #attempt to use a prefix when not allowed #review - by ending opts here - we dont' get the clearest error msgs # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error @@ -4267,10 +4381,10 @@ tcl::namespace::eval punk::args { #consider for example 'file delete -f -- old.txt' #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values #whereas the builtin file arg parser alerts that -f is a bad option - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #set arglist [lrange $rawargs 0 $i-1] - #set post_values [lrange $rawargs $i end] + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $all_opts" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $remaining_rawargs 0 $i-1] + #set post_values [lrange $remaining_rawargs $i end] #break } if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { @@ -4279,24 +4393,24 @@ tcl::namespace::eval punk::args { if {$i == $maxidx} { #if no optvalue following - assume it's a value #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] break } - set flagval [lindex $rawargs $i+1] + set flagval [lindex $remaining_rawargs $i+1] if {[tcl::dict::get $argstate $fullopt -multiple]} { #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] + if {$api_opt ni $flagsreceived} { + tcl::dict::set opts $api_opt [list $flagval] } else { - tcl::dict::lappend opts $fullopt $flagval + tcl::dict::lappend opts $api_opt $flagval } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt + if {$api_opt ni $multisreceived} { + lappend multisreceived $api_opt } } else { - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $api_opt $flagval } #incr i to skip flagval incr vals_remaining_possible -2 @@ -4307,22 +4421,22 @@ tcl::namespace::eval punk::args { } else { #solo if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { + if {$api_opt ni $flagsreceived} { #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 + tcl::dict::set opts $api_opt 1 } else { - tcl::dict::lappend opts $fullopt 1 + tcl::dict::lappend opts $api_opt 1 } - if {$fullopt ni $multisreceived} { + if {$api_opt ni $multisreceived} { lappend multisreceived $fullopt } } else { - tcl::dict::set opts $fullopt 1 + tcl::dict::set opts $api_opt 1 } incr vals_remaining_possible -1 - lappend solosreceived $fullopt ;#dups ok + lappend solosreceived $api_opt ;#dups ok } - lappend flagsreceived $fullopt ;#dups ok + lappend flagsreceived $api_opt ;#dups ok } else { #unmatched option flag #comparison to valmin already done above @@ -4333,12 +4447,12 @@ tcl::namespace::eval punk::args { #even with optany - assume an unknown within the space of possible values is a value #unmatched option in right position to be considered a value - treat like eopts #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] break } if {$OPT_ANY} { - set newval [lindex $rawargs $i+1] + set newval [lindex $remaining_rawargs $i+1] #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS @@ -4388,8 +4502,8 @@ tcl::namespace::eval punk::args { } } else { #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] break } } @@ -4398,8 +4512,8 @@ tcl::namespace::eval punk::args { set values $post_values } else { set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set values $remaining_rawargs + #set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected set arglist [list] } #puts stderr "--> arglist: $arglist" @@ -4407,11 +4521,13 @@ tcl::namespace::eval punk::args { #--------------------------------------- set ordered_opts [dict create] - foreach o $OPT_NAMES { + set unaliased_opts [lmap v $OPT_NAMES {lindex [split $v |] end}] + #unaliased_opts is list of 'api_opt' (handle aliases of form -a1|-a2|-api_opt e.g -fg|-foreground) + 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 $o]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } elseif {[dict exists $OPT_DEFAULTS $optset]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $optset] } } #add in possible '-any true' opts after the defined opts @@ -4425,8 +4541,7 @@ tcl::namespace::eval punk::args { set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" + set leadername_multiple "" set leadernames_received [list] set num_leaders [llength $leaders] @@ -4439,39 +4554,103 @@ tcl::namespace::eval punk::args { set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] #---------------------------------------- - #test args parse_withdef_leader_stride - todo - #change to for loop - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } + set start_position $positionalidx + set nameidx 0 + #MAINTENANCE - same loop logic as for values + for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { + set leadername [lindex $LEADER_NAMES $nameidx] + incr nameidx + set ldr [lindex $leaders $ldridx] if {$leadername ne ""} { + if {[llength $leadername] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername', but requires [llength $leadername] values" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + if {[tcl::dict::get $argstate $leadername -multiple]} { if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + #current stored ldr equals defined default - don't include default in the list we build up + tcl::dict::set leaders_dict $leadername [list $strideval] ;#important to treat first element as a list } else { - tcl::dict::lappend leaders_dict $leadername $ldr + tcl::dict::lappend leaders_dict $leadername $strideval } - set in_multiple $leadername + set leadername_multiple $leadername } else { - tcl::dict::set leaders_dict $leadername $ldr + tcl::dict::set leaders_dict $leadername $strideval } lappend leadernames_received $leadername } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + if {$leadername_multiple ne ""} { + if {[llength $leadername_multiple] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername_multiple { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername_multiple', but requires [llength $leadername_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + tcl::dict::lappend leaders_dict $leadername_multiple $strideval + #name already seen - but must add to leadernames_received anyway (as with opts and values) + lappend leadernames_received $leadername_multiple } else { tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } } - incr ldridx - incr positionalidx + set positionalidx [expr {$start_position + $ldridx + 1}] } + #test args parse_withdef_leader_stride - todo + #change to for loop + #foreach leadername $LEADER_NAMES ldr $leaders { + # if {$ldridx+1 > $num_leaders} { + # break + # } + # if {$leadername ne ""} { + # if {[tcl::dict::get $argstate $leadername -multiple]} { + # if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + # tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + # } else { + # tcl::dict::lappend leaders_dict $leadername $ldr + # } + # set leadername_multiple $leadername + # } else { + # tcl::dict::set leaders_dict $leadername $ldr + # } + # lappend leadernames_received $leadername + # } else { + # if {$leadername_multiple ne ""} { + # tcl::dict::lappend leaders_dict $leadername_multiple $ldr + # lappend leadernames_received $leadername_multiple ;#deliberately allow dups! (as with opts and values) + # } else { + # tcl::dict::set leaders_dict $positionalidx $ldr + # tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + # tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + # lappend leadernames_received $positionalidx + # } + # } + # incr ldridx + # incr positionalidx + #} + set validx 0 set valname_multiple "" @@ -4490,6 +4669,7 @@ tcl::namespace::eval punk::args { #------------------------------------------ set nameidx 0 set start_position $positionalidx + #MAINTENANCE - same loop logic as for leaders for {set validx 0} {$validx < [llength $values]} {incr validx} { set valname [lindex $VAL_NAMES $nameidx] incr nameidx @@ -4548,7 +4728,7 @@ tcl::namespace::eval punk::args { lappend valnames_received $positionalidx } } - set positionalidx [expr {$start_position + $validx}] + set positionalidx [expr {$start_position + $validx + 1}] } #------------------------------------------ @@ -4614,9 +4794,11 @@ tcl::namespace::eval punk::args { return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } - if {[llength [set missing [punklib_ldiff $OPT_REQUIRED $flagsreceived]]]} { - set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] + if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { + set full_missing [dict get $lookup_optset $missing] + set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs } if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { @@ -4636,6 +4818,13 @@ tcl::namespace::eval punk::args { #puts "---opts_and_values:$opts_and_values" #puts "---argstate:$argstate" tcl::dict::for {argname v} $opts_and_values { + if {[string match -* $argname]} { + #get full option name such as -fg|-foreground from non-alias name such as -foreground + #if "@opts -any true" - we may have an option that wasn't defined + if {[dict exists $lookup_optset $argname]} { + set argname [dict get $lookup_optset $argname] + } + } set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] set thisarg_checks [tcl::dict::get $arg_checks $argname] @@ -4693,7 +4882,7 @@ tcl::namespace::eval punk::args { } } #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + #(could be -multiple with -choicerestricted 0 where some selections match and others don't) if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels diff --git a/src/modules/punk/args-buildversion.txt b/src/modules/punk/args-buildversion.txt index ee099ef9..f8f1fe54 100644 --- a/src/modules/punk/args-buildversion.txt +++ b/src/modules/punk/args-buildversion.txt @@ -1,3 +1,3 @@ -0.1.7 +0.1.8 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index f373f9c1..78bd01c0 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -1479,7 +1479,7 @@ tcl::namespace::eval punk::args::tclcore { is synonymous with lindex [lindex [lindex $a 1] 2] 3 - When presented with a single indes, the lindex command treats list as a Tcl list + When presented with a single index, the lindex command treats list as a Tcl list and returns the index'th element from it (0 refers to the first element of the list). In extracting the element, lindex observes the same rules concerning braces and quotes and backslashes as the Tcl command interpreter; however, @@ -1593,7 +1593,7 @@ tcl::namespace::eval punk::args::tclcore { "tcl list as a value" first -type indexexpression -help\ "index expression for first element" - last -type indexepxression -help\ + last -type indexexpression -help\ "index expression for last element" } "@doc -name Manpage: -url [manpage_tcl lrange]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -1804,7 +1804,7 @@ tcl::namespace::eval punk::args::tclcore { of the characters in ${$I}splitChars${$NI}. Empty list elements will be generated if string contains adjacent characters in ${$I}splitChars${$NI}, or if the first or last character of string is in ${$I}splitChars${$NI}. - If ${I}splitChars${$NI} is an empty string then each character of ${$I}string${$NI} + If ${$I}splitChars${$NI} is an empty string then each character of ${$I}string${$NI} becomes a separate element of the result list. ${$I}splitChars${$NI} defaults to the standard white-space characters." @values -min 1 -max 2 diff --git a/src/modules/punk/args/tzint-999999.0a1.0.tm b/src/modules/punk/args/tzint-999999.0a1.0.tm new file mode 100644 index 00000000..83a71549 --- /dev/null +++ b/src/modules/punk/args/tzint-999999.0a1.0.tm @@ -0,0 +1,307 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::args::tzint 999999.0a1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::args::tzint 0 999999.0a1.0] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::args::tzint] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::args::tzint +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args::tzint +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +tcl::namespace::eval punk::args::tzint { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::args::tzint}] + #[para] Core API functions for punk::args::tzint + #[list_begin definitions] + + variable PUNKARGS + + namespace eval argdoc { + proc get_symbologies {} { + if {[catch { + package require tzint + ::tzint::Encode symbologies + } result]} { + return + } else { + return $result + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tzint::Encode + @cmd -name "native tzint::Encode" -help\ + "" + @leaders -min 1 -max 1 + command -type string -choices {version symbologies bits eps svg xbm} + @values -min 0 -max 0 + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + lappend PUNKARGS [list { + @id -id "::tzint::Encode version" + @cmd -name "native tzint::Encode version" -help\ + "Return the version of underlying libzint" + @values -min 0 -max 0 + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + + lappend PUNKARGS [list { + @id -id "::tzint::Encode symbologies" + @cmd -name "native tzint::Encode symbologies" -help\ + "Return a list of symbology names that can be encoded. + These are values that can be supplied for the -symbology flag" + @values -min 0 -max 0 + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + + lappend PUNKARGS [list { + @dynamic + @id -id "::tzint::Encode svg" + @cmd -name "native tzint::Encode svg" + @leaders -min 0 -max 2 + "varName data" -type {string string} -optional 1 + @opts + -symbology -type string -choicerestricted 0 -choices {${[::punk::args::tzint::argdoc::get_symbologies]}} + -height -type integer -help\ + "The height of a 1d symbol" + -whitespace -type integer -help\ + "The amount of whitespace to the left and right of the generated barcode" + -bind -type boolean -default 0 -help\ + "tzint allows the symbol to be bound with 'boundary bars' + These bars help to prevent misreading of the symbol by corrupting + a scan if the scanning beam strays off the top or bottom of the symbol." + -box -type boolean -help\ + "Puts a border right around the symbol and its whitespace. + This option is automatically selected for ITF-14 symbols." + -border -type integer -help\ + "Specifies width of boundary or box." + -fg|-foreground -type string -default "000000" -help\ + "Foreground colour specified in RGB hexadecimal notation." + -bg|-background -type string -default "FFFFFF" -help\ + "Background colour specified in RGB hexadecimal notation." + -rotate -type integer -default 0 -choices {0 90 180 270} -help\ + "The symbol can be rotated through four orientations + by specifying one of the allowed angles of rotation." + -scale -type integer + -format -type string + -stat -type string -help\ + "variable name for status data" + #barcode specific options + #TODO - what? + -cols -type integer -help\ + "number of columns PDF417" + -vers -type integer -help\ + "option QR Code and Plessy" + -security -type integer -help\ + "error correction level PDF417 and QR Code" + -mode -type integer -help\ + "structured primary data mode Maxicode and Composite" + -primary -type string -help\ + "structured primary data Maxicode and Composite" + -notext -type boolean -help\ + "no interpretation line" + -square -type boolean -help\ + "force DataMatrix symbols to be square" + -init -type boolean -help\ + "create reader initialisation symbol Code128 and DataMatrix" + -smalltext -type boolean -help\ + "tiny interpretation line font" + #Changing the '0'/'1' character when using the bits command -- then -onchar and/or -offchar can be used + -onchar -type char + -offchar -type char + @values -min 0 -max 0 + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + + lappend PUNKARGS [list { + @dynamic + @id -id "::tzint::Encode xbm" + @cmd -name "native tzint::Encode xbm" + ${[punk::args::resolved_def -antiglobs {@id @cmd} "::tzint::Encode svg"]} + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::tzint ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::args::tzint { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::args::tzint" + @package -name "punk::args::tzint" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::args::tzint + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::args::tzint + description to come.. + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::args::tzint::version" + } + proc get_topic_Contributors {} { + set authors {} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::args::tzint::about" + dict set overrides @cmd -name "punk::args::tzint::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::args::tzint + documentation for tzint package + }] \n] + dict set overrides topic -choices [list {*}[punk::args::tzint::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::args::tzint::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::args::tzint::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::args::tzint::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::args::tzint ::punk::args::tzint::argdoc +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args::tzint [tcl::namespace::eval punk::args::tzint { + variable pkg punk::args::tzint + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/args/tzint-buildversion.txt b/src/modules/punk/args/tzint-buildversion.txt new file mode 100644 index 00000000..44547ff1 --- /dev/null +++ b/src/modules/punk/args/tzint-buildversion.txt @@ -0,0 +1,3 @@ +1.1.1 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test index 432e9f6d..99f145aa 100644 --- a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test @@ -34,7 +34,7 @@ namespace eval ::testspace { namespace eval testns { punk::args::define { @id -id ::testspace::testns::t1 - @leaders -min 1 + @leaders subcmd -default c1 -choices {c1 c2} @values -min 0 -max 0 } @@ -52,7 +52,7 @@ namespace eval ::testspace { namespace delete ::testspace::testns }\ -result [list\ - "::testspace::testns::t1 [a+ italic]subcmd[a]"\ + "::testspace::testns::t1 ?[a+ italic]subcmd[a]?"\ "::testspace::testns::t1 c1 [a+ italic]v1[a]" ]