From f13f2f6f619105a2583869aa3e8ae17c6b954db9 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Tue, 24 Jun 2025 12:44:35 +1000 Subject: [PATCH] punk::args fixes and more tclcore documentation --- src/modules/punk/ansi-999999.0a1.0.tm | 68 +- src/modules/punk/args-999999.0a1.0.tm | 2905 ++++++++++++----- src/modules/punk/args-buildversion.txt | 2 +- src/modules/punk/args/tclcore-999999.0a1.0.tm | 1663 ++++++++-- .../cap/handlers/templates-999999.0a1.0.tm | 11 +- src/modules/punk/nav/fs-999999.0a1.0.tm | 6 +- src/modules/punk/ns-999999.0a1.0.tm | 40 +- src/modules/shellrun-0.1.1.tm | 73 +- .../args-0.1.5_testsuites/args/args.test | 178 +- src/modules/textblock-999999.0a1.0.tm | 74 +- 10 files changed, 3765 insertions(+), 1255 deletions(-) diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 8b161608..238174c1 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -3463,7 +3463,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set emit "" #set parts [punk::ansi::ta::split_codes $text] set parts [punk::ansi::ta::split_codes_single $text] - foreach {pt codegroup} $parts { + foreach {pt code} $parts { switch -- [llength $codestack] { 0 { append emit $base $pt $R @@ -3489,46 +3489,44 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - #parts ends on a pt - last codegroup always empty string - if {$codegroup ne ""} { - foreach code [punk::ansi::ta::get_codes_single $codegroup] { - set c1c2 [tcl::string::range $code 0 1] - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] - switch -- $leadernorm { - 7CSI - 8CSI { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #todo - make caching is_sgr method - set dup_posns [lsearch -all -exact $codestack $code] - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { + #parts ends on a pt - last code always empty string + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] + switch -- $leadernorm { + 7CSI - 8CSI { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #todo - make caching is_sgr method + set dup_posns [lsearch -all -exact $codestack $code] + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { - } } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set o_gx_state on - } - "B" { - set o_gx_state off - } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set o_gx_state on + } + "B" { + set o_gx_state off } } - default { - #other ansi codes - } } - append emit $code + default { + #other ansi codes + } } + append emit $code } } return [append emit $R] diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 79fd3a41..be445500 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -378,16 +378,18 @@ tcl::namespace::eval punk::args { %B%@cmd%N% ?opt val...? directive-options: -name -help %B%@leaders%N% ?opt val...? - directive-options: -min -max (used for leading args that come before switches/opts) + directive-options: -min -max -unnamed + (also accepts options as defaults for subsequent arguments) %B%@opts%N% ?opt val...? - directive-options: -any + directive-options: -any|-arbitrary %B%@values%N% ?opt val...? - directive-options: -min -max (used for trailing args that come after switches/opts) + directive-options: -min -max -unnamed + (also accepts options as defaults for subsequent arguments) %B%@form%N% ?opt val...? - directive-options: -form -synopsis (used for commands with multiple forms) + directive-options: -form -synopsis The -synopsis value allows overriding the auto-calculated synopsis. %B%@formdisplay%N% ?opt val...? @@ -424,30 +426,60 @@ tcl::namespace::eval punk::args { custom leading args, switches/options (names starting with -) and trailing values also take spec-options: - -type + -type defaults to string. If no other restrictions are specified, choosing string does the least validation. recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer + int + integer + number list indexexpression dict double - bool|boolean + float + bool + boolean char file directory - string ansistring globstring (any of the types accepted by 'string is') - These all perform some validation checks + The above all perform some validation checks + + string + (also any of the 'string is' types such as + xdigit, graph, punct, lower etc) + any + (unvalidated - accepts anything) + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + + literal() + (exact match for string) + literalprefix() + (prefix match for string, other literal and literalprefix + entries specified as alternates using | are used in the + calculation) + + Note that types can be combined with | to indicate an 'or' + operation + e.g char|int + e.g literal(xxx)|literal(yyy) + e.g literalprefix(text)|literalprefix(binary) + (when all in the pipe-delimited type-alternates set are + literal or literalprefix - this is similar to the -choices + option) + and more.. (todo - document here) + If a typenamelist is supplied and has length > 1 + then -typeranges must be used instead of -range + The number of elements in -typeranges must match + the number of elements specified in -type. -optional (defaults to true for flags/switches false otherwise) @@ -499,6 +531,9 @@ tcl::namespace::eval punk::args { the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full choice argument must be entered to select the choice. + -choiceprefixreservelist {} + These choices are additional values used in prefix calculation. + The values will not be added to the list of available choices. -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name (or the empty @@ -523,7 +558,8 @@ tcl::namespace::eval punk::args { entries in -choices/-choicegroups. -minsize (type dependant) -maxsize (type dependant) - -range (type dependant) + -range (type dependant - only valid if -type is a single item) + -typeranges (list with same number of elements as -type) " @@ -579,7 +615,7 @@ tcl::namespace::eval punk::args { proc New_command_form {name} { #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ + set leaderdirective_defaults [tcl::dict::create\ -type string\ -optional 0\ -allow_ansi 1\ @@ -594,7 +630,7 @@ tcl::namespace::eval punk::args { -validationtransform {}\ -ensembleparameter 0\ ] - set optspec_defaults [tcl::dict::create\ + set optdirective_defaults [tcl::dict::create\ -type string\ -optional 1\ -allow_ansi 1\ @@ -609,7 +645,7 @@ tcl::namespace::eval punk::args { -validationtransform {}\ -prefix 1\ ] - set valspec_defaults [tcl::dict::create\ + set valdirective_defaults [tcl::dict::create\ -type string\ -optional 0\ -allow_ansi 1\ @@ -635,21 +671,25 @@ tcl::namespace::eval punk::args { LEADER_NAMES [list]\ LEADER_MIN ""\ LEADER_MAX ""\ - LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_UNNAMED false\ + LEADERSPEC_DEFAULTS $leaderdirective_defaults\ LEADER_CHECKS_DEFAULTS {}\ OPT_DEFAULTS [tcl::dict::create]\ OPT_REQUIRED [list]\ OPT_NAMES [list]\ OPT_ANY 0\ + OPT_MIN ""\ + OPT_MAX ""\ OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optspec_defaults\ + OPTSPEC_DEFAULTS $optdirective_defaults\ OPT_CHECKS_DEFAULTS {}\ VAL_DEFAULTS [tcl::dict::create]\ VAL_REQUIRED [list]\ VAL_NAMES [list]\ VAL_MIN ""\ VAL_MAX ""\ - VALSPEC_DEFAULTS $valspec_defaults\ + VAL_UNNAMED false\ + VALSPEC_DEFAULTS $valdirective_defaults\ VAL_CHECKS_DEFAULTS {}\ FORMDISPLAY [tcl::dict::create]\ ] @@ -996,7 +1036,7 @@ tcl::namespace::eval punk::args { set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict if {[llength $record_values] % 2 != 0} { #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" } # ---------------------------------------------------------- # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. @@ -1082,7 +1122,7 @@ tcl::namespace::eval punk::args { if {[dict exists $at_specs -id]} { set thisid [dict get $at_specs -id] if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" + error "punk::args::resolve @id mismatch existing: $id vs $thisid" } } set id_info $at_specs @@ -1202,7 +1242,7 @@ tcl::namespace::eval punk::args { opts { foreach fid $record_form_ids { if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + error "punk::args::resolve - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" } tcl::dict::set F $fid argspace "options" set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] @@ -1212,12 +1252,21 @@ tcl::namespace::eval punk::args { -form { #review - handled above } - -any - + -any - -arbitrary - -anyopts { #set opt_any $v tcl::dict::set F $fid OPT_ANY $v } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + -min { + dict set F $fid OPT_MIN $v + } + -max { + #if no -max explicitly specified, and llength OPT_NAMES == 0 and OPT_ANY == 0 - -max will be set to 0 below. + dict set F $fid OPT_MAX $v + } + -minsize - -maxsize - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - + -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { #review - only apply to certain types? tcl::dict::set tmp_optspec_defaults $k $v } @@ -1228,51 +1277,64 @@ tcl::namespace::eval punk::args { } } -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - index { - set v indexexpression - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } + #v is a typelist + #foreach t $v { + # #validate? + #} tcl::dict::set tmp_optspec_defaults -type $v } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - + -range { + if {[dict exists $at_specs -type]} { + set tp [dict get $at_specs -type] + } else { + set tp [dict get $tmp_optspec_defaults -type] + } + if {[llength $tp] == 1} { + tcl::dict::set tmp_optspec_defaults -typeranges [list $v] + } else { + error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id" + } + } + -typeranges { + if {[dict exists $at_specs -type]} { + set tp [dict get $at_specs -type] + } else { + set tp [dict get $tmp_optspec_defaults -type] + } + if {[llength $tp] != [llength $v]} { + error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -typeranges has length [llength $v]. Lengths must match. @id:$DEF_definition_id" + } + tcl::dict::set tmp_optspec_defaults -typeranges $v + } -regexprepass - -regexprefail - -regexprefailmsg - -validationtransform - + -validationtransform { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - -multiple - -prefix { - #allow overriding of defaults for options that occur later + #check is bool + if {![string is boolean -strict $v]} { + error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id" + } tcl::dict::set tmp_optspec_defaults $k $v } default { - set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + set known { -any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ + -type -range -typeranges -default -typedefaults + -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" } } } @@ -1282,7 +1344,7 @@ tcl::namespace::eval punk::args { leaders { foreach fid $record_form_ids { if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + error "punk::args::resolve - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" } set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] @@ -1294,7 +1356,7 @@ tcl::namespace::eval punk::args { -min - -minvalues { if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" } dict set F $fid LEADER_MIN $v #if {$leader_max == 0} { @@ -1304,17 +1366,20 @@ tcl::namespace::eval punk::args { -max - -maxvalues { if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" } dict set F $fid LEADER_MAX $v } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? + -choiceprefix - + -choicerestricted { + if {![string is boolean -strict $v]} { + error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" + } tcl::dict::set tmp_leaderspec_defaults $k $v } - -choiceinfo { + -choiceinfo - -choicelabels { if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" } tcl::dict::set tmp_leaderspec_defaults $k $v } @@ -1326,56 +1391,84 @@ tcl::namespace::eval punk::args { } } -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } + #$v is a list of types + #foreach t $v { + #validate? + #} + #switch -- $v { + # int - integer { + # set v int + # } + # char - character { + # set v char + # } + # bool - boolean { + # set v bool + # } + # dict - dictionary { + # set v dict + # } + # list { + + # } + # index { + # set v indexexpression + # } + # default { + # #todo - disallow unknown types unless prefixed with custom- + # } + #} + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -range { + tcl::dict::set tmp_leaderspec_defaults -range $v + } + -typeranges { + tcl::dict::set tmp_leaderspec_defaults -range $v + } + -minsize - -maxsize - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefixdenylist - -choiceprefixreservelist - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform { tcl::dict::set tmp_leaderspec_defaults $k $v } -optional - -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - -multiple { + if {![string is boolean -strict $v]} { + error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" + } tcl::dict::set tmp_leaderspec_defaults $k $v } + -unnamed { + if {![string is boolean -strict $v]} { + error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" + } + dict set F $fid LEADER_UNNAMED $v + } -ensembleparameter { #review tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + #error "punk::args::resolve - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" } default { set known { -min -form -minvalues -max -maxvalues\ -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ + -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -unnamed\ } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + error "punk::args::resolve - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" } } } @@ -1398,7 +1491,7 @@ tcl::namespace::eval punk::args { -min - -minvalues { if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + error "punk::args::resolve - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" } #set val_min $v dict set F $fid VAL_MIN $v @@ -1406,18 +1499,19 @@ tcl::namespace::eval punk::args { -max - -maxvalues { if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + error "punk::args::resolve - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" } #set val_max $v dict set F $fid VAL_MAX $v } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + -minsize - -maxsize - -choices - -choicemultiple - -choicecolumns - + -choicelabels - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set tmp_valspec_defaults $k $v } -choiceinfo - -choicegroups { if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" } tcl::dict::set tmp_valspec_defaults $k $v } @@ -1454,27 +1548,47 @@ tcl::namespace::eval punk::args { } tcl::dict::set tmp_valspec_defaults $k $v } + -range { + tcl::dict::set tmp_valspec_defaults -range $v + } + -typeranges { + tcl::dict::set tmp_valspec_defaults -typeranges $v + } -optional - -allow_ansi - -validate_ansistripped - -strip_ansi - + -multiple { + if {![string is boolean -strict $v]} { + error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } -regexprepass - -regexprefail - -regexprefailmsg - - -validationtransform - - -multiple { + -validationtransform { tcl::dict::set tmp_valspec_defaults $k $v } + -unnamed { + if {![string is boolean -strict $v]} { + error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" + } + dict set F $fid VAL_UNNAMED $v + } default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + set known { -type -range -typeranges\ + -min -form -minvalues -max -maxvalues\ + -minsize -maxsize\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ + -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -nocase\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -unnamed\ } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + error "punk::args::resolve - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" } } } @@ -1492,25 +1606,122 @@ tcl::namespace::eval punk::args { set keywords_info [dict merge $keywords_info $at_specs] } default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } #record_type directive continue } elseif {$firstchar eq "-"} { - set argname $firstword set argdef_values $record_values + #Note that we can get options defined with aliases e.g "-x|-suppress" + #Here we store the full string as the argname - but in the resulting dict upon parsing it will have the final + # entry as the key for retrieval e.g {leaders {} opts {-suppress true} values {} ...} + + #we can also have longopts within the list e.g "-f|--filename=" + #This accepts -f or --filename= + # (but not --filename ) + #if the clausemember is optional - then the flag can act as a solo, but a parameter can only be specified on the commandline with an = + #e.g "-x|--something= -type ?string? + #accepts all of: + # -x + # --something + # --something=blah + + + #while most longopts require the = some utilities (e.g fossil) + #accept --longname + #(fossil accepts either --longopt or --longopt=) + #For this reason, "-f|--filename" is different to gnu-style longopt "-f|--filename=" + + #for "--filename=" we can specify an 'optional' clausemember using for example -type ?string? + + #4? cases + #1) + #--longopt + # (not really a longopt - can only parse with --longopt - [optional member not supported, but could be solo if -type none]) + #2) + #--longopt= + # (gnu style longopt - parse with --longopt= - solo allowed if optional member - does not support solo via -type none) + #3) + #--longopt|--longopt= -types int + # (mixed - as fossil does - parse with --longopt= or --longopt [optional member not supported?]) + #4) + # --xxx|--longopt= -types {?int?} + #(repeating such as --longopt --longopt= not valid?) + #redundant? + #ie --longopt|--longopt= -types {?int?} + # equivalent to + # --longopt= -types {?int?} + #allow parsing -xxx only as solo and --longopt as solo or --longopt=n ? + + #the above set would not cover the edge-case where we have an optional member but we don't want --longopt to be allowed solo + #e.g + #-soloname|--longopt= -types ?int? + #allows parsing "-soloname" or "--longopt" or "--longopt=n" + #but what if we want it to mean only accept: + # "-soloname" or "--longopt=n" ?? + + #we deliberately don't support + #--longopt -type ?type? + #or -opt -type ?type? + #as this results in ambiguities and more complexity in parsing depending on where flag occurs in args compared to positionals + + #for these reasons - we can't only look for leading -- here to determine 'longopt' + + + set argname $firstword + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #do some basic validation here + #1 "-type none" would not be valid for "--filename=" + #2 a -type can only be optional (specified as -type ?xxx?) if at least one entry in the argname has a trailing = + #3 require --longopt if has a trailing =. ie disallow -opt= ? + + set has_equal 0 + set optaliases [split $firstword |] + if {[lsearch $optaliases *=] >=0} { + set has_equal 1 + } + #todo - if no -type specified in this flag record, we still need to check the default -type from the @opts record - which could have been + #overridden from just 'string' + if {[tcl::dict::exists $argdef_values -type]} { + set tp [tcl::dict::get $argdef_values -type] + if {[llength $tp] != 1} { + #clauselength > 1 not currently supported for flags + #e.g -myflag -type {list int} + # e.g called on commandline with cmd -myflag {a b c} 3 + #review - seems an unlikely and complicating feature to allow - evidence of tools using/supporting this in the wild not known of. + error "punk::args::resolve - Multiple space-separated arguments (as indicated by -type having multiple entries) for a flag are not supported. flag $argname -type '$tp' @id:$DEF_definition_id" + } + if {$argname eq "--"} { + if {$tp ne "none"} { + #error to explicitly attempt to configure -- as a value-taking option + error "punk::args::resolve - special flag named -- cannot be configured as a value-accepting flag. set -type none or omit -type from definition. @id:$DEF_definition_id" + } + } + if {$tp eq "none"} { + if {$has_equal} { + error "punk::args::resolve - flag type 'none' (indicating non-parameter-taking flag) is not supported when any flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id" + } + } elseif {[string match {\?*\?} $tp]} { + #optional flag value + if {!$has_equal} { + error "punk::args::resolve - Optional flag parameter (as indicated by leading & trailing ?) is not supported when no flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + tcl::dict::set argdef_values -ARGTYPE option foreach fid $record_form_ids { if {[dict get $F $fid argspace] eq "leaders"} { dict set F $fid argspace "options" } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + error "punk::args::resolve - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" } set record_type option dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname } set is_opt 1 @@ -1533,7 +1744,7 @@ tcl::namespace::eval punk::args { tcl::dict::set F $fid LEADER_NAMES $temp_leadernames } else { #This can happen if the definition has repeated values - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + error "punk::args::resolve - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" } if {[dict get $F $fid LEADER_MAX] >= 0} { @@ -1550,7 +1761,7 @@ tcl::namespace::eval punk::args { lappend temp_valnames $argname tcl::dict::set F $fid VAL_NAMES $temp_valnames } else { - error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + error "punk::args::resolve - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" } #lappend val_names $argname if {[dict get $F $fid VAL_MAX] >= 0} { @@ -1588,58 +1799,108 @@ tcl::namespace::eval punk::args { } -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - index - indexexpression { - tcl::dict::set spec_merged -type indexexpression + #todo - could be a list e.g {any int literal(Test)} + #case must be preserved in literal bracketed part + set typelist [list] + foreach typespec $specval { + set lc_typespec [tcl::string::tolower $typespec] + if {[string match {\?*\?} $lc_typespec]} { + set lc_type [string range $lc_typespec 1 end-1] + set optional_clausemember true + } else { + set lc_type $lc_typespec + set optional_clausemember false } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + #normalize here so we don't have to test during actual args parsing in main function + set normtype "" ;#assert - should be overridden in all branches of switch + switch -- $lc_type { + int - integer { + set normtype int + } + double - float { + #review - user may wish to preserve 'float' in help display - consider how best to implement + set normtype double + } + bool - boolean { + set normtype bool + } + char - character { + set normtype char + } + dict - dictionary { + set normtype dict + } + index - indexexpression { + set normtype indexexpression + } + "" - none - solo { + if {$is_opt} { + #review - are we allowing clauses for flags? + #e.g {-flag -type {int int}} + #this isn't very tcl like, where we'd normally mark the flag with -multiple true and + # instead require calling as: -flag -flag + #It seems this is a reasonably rare/unlikely requirement in most commandline tools. + + if {[llength $specval] > 1} { + #makes no sense to have 'none' in a clause + error "punk::args::resolve - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" + } + #tcl::dict::set spec_merged -type none + set normtype none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #solo only valid for flags + error "punk::args::resolve - invalid -type 'none|solo' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id" } - } else { - #-solo only valid for flags - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - literal { - #value is the name of the argument - if {$is_opt} { - error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + any - anything { + set normtype any + } + ansi - ansistring { + set normtype ansistring + } + string - globstring { + set normtype $lc_type + } + literal { + if {$is_opt} { + error "punk::args::resolve - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + #value is the name of the argument + set normtype literal + } + default { + if {[string match literal* $lc_type]} { + #typespec may or may not be of form ?xxx? + set literal_tail [string range [string trim $typespec ?] 7 end] + set normtype literal$literal_tail + } else { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + #tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + set normtype $lc_type + } } - tcl::dict::set spec_merged -type literal } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + if {$optional_clausemember} { + lappend typelist ?$normtype? + } else { + lappend typelist $normtype } } + tcl::dict::set spec_merged -type $typelist + } + -typesynopsis { + set typecount [llength [tcl::dict::get $spec_merged -type]] + if {$typecount != [llength $specval]} { + error "punk::args::resolve - invalid -typesynopsis specification for argument '$argname'. -typesynopsis has [llength $specval] entries, but requires $typecount entries (one for each entry in -types. Use empty string list members for default) @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -typesynopsis $specval } - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -solo - + -choices - -choicegroups - -choicemultiple - -choicecolumns - + -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - -minsize - -maxsize - -nocase - -multiple - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - -regexprepass - -regexprefail - -regexprefailmsg @@ -1648,38 +1909,71 @@ tcl::namespace::eval punk::args { #review -solo 1 vs -type none ? conflicting values? tcl::dict::set spec_merged $spec $specval } + -range { + #allow simple case to be specified without additional list wrapping + #only multi-types require full list specification + #arg1 -type int -range {0 4} + #arg2 -type {int string} -range {{0 4} {"" ""}} + set typecount [llength [tcl::dict::get $spec_merged -type]] + if {$typecount == 1} { + tcl::dict::set spec_merged -typeranges [list $specval] + } else { + error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id" + } + } + -typeranges { + set typecount [llength [tcl::dict::get $spec_merged -type]] + if {$typecount != [llength $specval]} { + error "punk::args::resolve - invalid -typeranges specification for argument '$argname'. -typeranges has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -typeranges $specval + } -default { + #The -default is for when the entire clause is missing + #It doesn't necessarily have to have the same number of elements as the clause {llength $typelist} + #review tcl::dict::set spec_merged -default $specval if {![dict exists $argdef_values -optional]} { tcl::dict::set spec_merged -optional 1 } } + -typedefaults { + set typecount [llength [tcl::dict::get $spec_merged -type]] + if {$typecount != [llength $specval]} { + error "punk::args::resolve - invalid -typedefaults specification for argument '$argname'. -typedefaults has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -typedefaults $specval + } -optional { + #applies to whole arg - not each -type tcl::dict::set spec_merged -optional $specval } -ensembleparameter { + #applies to whole arg - not each -type #review - only leaders? tcl::dict::set spec_merged $spec $specval } -prefix { + #applies to whole arg - not each -type #for flags/options tcl::dict::set spec_merged $spec $specval } -validationtransform { #string is dict only 8.7/9+ if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" } dict for {tk tv} $specval { switch -- $tk { - -function - -type - -minsize - -maxsize - -range { + -command - -function - -type - -minsize - -maxsize - -range { } default { set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + error "punk::args::resolve - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" } } } + #TODO! } default { @@ -1687,7 +1981,7 @@ tcl::namespace::eval punk::args { #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" } else { set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" if {$targetswitch eq "-*"} { @@ -1696,17 +1990,19 @@ tcl::namespace::eval punk::args { if {[tcl::dict::exists $refs $specval $targetswitch]} { tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" } } } } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + set known_argopts [list -form -type -range -typeranges\ + -default -typedefaults -minsize -maxsize -choices -choicegroups\ + -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ -ensembleparameter\ ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + error "punk::args::resolve - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" } } } @@ -1716,8 +2012,11 @@ tcl::namespace::eval punk::args { if {$is_opt} { tcl::dict::set F $fid ARG_CHECKS $argname\ [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {$argname eq "--"} { + #force -type none - in case no -type was specified and @opts -type is some other default such as string + tcl::dict::set spec_merged -type none + } if {[tcl::dict::get $spec_merged -type] eq "none"} { - #JJJJ dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] } } else { @@ -1726,7 +2025,8 @@ tcl::namespace::eval punk::args { } tcl::dict::set F $fid ARG_INFO $argname $spec_merged #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + #if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} {} + if {![tcl::dict::get $spec_merged -optional]} { if {$is_opt} { set temp_opt_required [dict get $F $fid OPT_REQUIRED] lappend temp_opt_required $argname @@ -1743,6 +2043,8 @@ tcl::namespace::eval punk::args { } } } + + if {[tcl::dict::exists $spec_merged -default]} { if {$is_opt} { #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] @@ -1769,6 +2071,12 @@ tcl::namespace::eval punk::args { #now cycle through ALL forms not just form_ids_active (record_form_ids) dict for {fid formdata} $F { + if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { + if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { + tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily + #review - when using resolved_def to create a definiation based on another - OPT_MAX may need to be overridden - a bit ugly? + } + } # REVIEW #no values specified - we can allow last leader to be multiple foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { @@ -3117,6 +3425,9 @@ tcl::namespace::eval punk::args { if {[llength [dict get $form_dict OPT_NAMES]]} { set all_opts [list] foreach optset [dict get $form_dict OPT_NAMES] { + #e.g1 "-alias1|-realname" + #e.g2 "-f|--filename" (fossil longopt style) + #e.g3 "-f|--filename=" (gnu longopt style) set optmembers [split $optset |] lappend all_opts {*}$optmembers foreach o $optmembers { @@ -3136,6 +3447,9 @@ tcl::namespace::eval punk::args { } set goodargs $full_goodargs if {![catch {package require punk::trie}]} { + #todo - reservelist for future options - or just to affect the prefix calculation + # (similar to -choiceprefixreservelist) + set trie [punk::trie::trieclass new {*}$all_opts --] set idents [dict get [$trie shortest_idents ""] scanned] #todo - check opt_prefixdeny @@ -3195,8 +3509,8 @@ tcl::namespace::eval punk::args { set parsed_values [Dict_getdef $parsedargs values {}] #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentset argnames_display argnames parsedvalues + foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names $parsed_leaders] [list opts $opt_names_display $opt_names $parsed_opts] [list values $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentclassinfo argumentclass argnames_display argnames parsedvalues foreach argshow $argnames_display arg $argnames { set arginfo [dict get $form_dict ARG_INFO $arg] @@ -3216,6 +3530,7 @@ tcl::namespace::eval punk::args { lassign $choicemultiple choicemultiple_min choicemultiple_max set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + set choiceprefixreservelist [Dict_getdef $arginfo -choiceprefixreservelist {}] ;#names used to calc prefix - but not available as actual choice. if {[Dict_getdef $arginfo -multiple 0]} { set multiple $greencheck set is_multiple 1 @@ -3228,6 +3543,7 @@ tcl::namespace::eval punk::args { } else { set choicegroups [dict merge [dict create "" $choices] $choicegroups] } + #review - does choiceprefixdenylist need to be added? dict for {groupname clist} $choicegroups { lappend allchoices_originalcase {*}$clist } @@ -3237,10 +3553,10 @@ tcl::namespace::eval punk::args { if {$help ne ""} {append help \n} if {[dict get $arginfo -nocase]} { set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] + set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist] } else { set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase + set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist] } if {[dict get $arginfo -choiceprefix]} { set prefixmsg " (choice prefix allowed)" @@ -3308,7 +3624,7 @@ tcl::namespace::eval punk::args { } } else { if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] + set trie [punk::trie::trieclass new {*}$allchoices_prefixcalc] set idents [dict get [$trie shortest_idents ""] scanned] if {[dict get $arginfo -nocase]} { #idents were calculated on lcase - remap keys in idents to original casing @@ -3513,8 +3829,16 @@ tcl::namespace::eval punk::args { if {[dict exists $arginfo -maxsize]} { append typeshow \n "-maxsize [dict get $arginfo -maxsize]" } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" + if {[dict exists $arginfo -typeranges]} { + set ranges [dict get $arginfo -typeranges] + if {[llength $ranges] == 1} { + append typeshow \n "-range [lindex [dict get $arginfo -typeranges] 0]" + } else { + append typeshow \n "-ranges" + foreach r $ranges { + append typeshow " {$r}" + } + } } if {$use_table} { @@ -3538,7 +3862,82 @@ tcl::namespace::eval punk::args { lappend errlines $arghelp } } - } + + # ------------------------------------------------------------------------------------------------------- + # if the argument class can accept unnamed arguments (or if opts accepts unspecified flags) - display an indication + # ------------------------------------------------------------------------------------------------------- + switch -- $argumentclass { + leaders - values { + if {$argumentclass eq "leaders"} { + set class_unnamed LEADER_UNNAMED + set class_max LEADER_MAX + set class_required LEADER_REQUIRED + set class_directive_defaults LEADERSPEC_DEFAULTS + } else { + set class_unnamed VAL_UNNAMED + set class_max VAL_MAX + set class_required VAL_REQUIRED + set class_directive_defaults VALSPEC_DEFAULTS + } + if {[dict get $form_dict $class_unnamed]} { + set valmax [dict get $form_dict $class_max] + #set valmin [dict get $form_dict VAL_MIN] + if {$valmax eq ""} { + set valmax -1 + } + if {$valmax == -1} { + set possible_unnamed -1 + } else { + set possible_unnamed [expr {$valmax - [llength [dict get $form_dict $class_required]]}] + if {$possible_unnamed < 0} { + set possible_unnamed 0 + } + } + if {$possible_unnamed == -1 || $possible_unnamed > 0} { + #Note 'multiple' is always empty here as each unnamed is assigned to its own positional index + if {$possible_unnamed == 1} { + set argshow ?? + } else { + set argshow ?...? + } + set tp [dict get $form_dict $class_directive_defaults -type] + if {[dict exists $form_dict $class_directive_defaults -default]} { + set default [dict get $form_dict $class_directive_defaults -default] + } else { + set default "" + } + if {$use_table} { + $t add_row [list "$argshow" $tp $default "" ""] + } else { + set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" + lappend errlines $arghelp + } + } + } + } + opts { + #display row to indicate if -any|-arbitrary true + + #review OPTSPEC_DEFAULTS -multiple ? + if {[dict get $form_dict OPT_ANY]} { + set argshow "?...?" + set tp [dict get $form_dict OPTSPEC_DEFAULTS -type] + if {[dict exists $form_dict OPTSPEC_DEFAULTS -default]} { + set default [dict get $form_dict OPTSPEC_DEFAULTS -default] + } else { + set default "" + } + if {$use_table} { + $t add_row [list "$argshow" $tp $default "" ""] + } else { + set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" + lappend errlines $arghelp + } + } + } + } + + } ;#end foreach argumentclass } ;#end is_custom_argdisplay if {$use_table} { @@ -3559,11 +3958,11 @@ tcl::namespace::eval punk::args { append errmsg [join $errlines \n] } } errM]} { - catch {$t destroy} append errmsg \n append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n append errmsg "$errM" \n append errmsg "$::errorInfo" + catch {$t destroy} } set arg_error_isrunning 0 @@ -3747,6 +4146,7 @@ tcl::namespace::eval punk::args { }] proc parse {args} { + #puts "punk::args::parse --> '$args'" set tailtype "" ;#withid|withdef if {[llength $args] < 3} { #error "punk::args::parse - invalid call. < 3 args" @@ -3831,6 +4231,7 @@ tcl::namespace::eval punk::args { } set id [lindex $tailargs 0] #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" set deflist [raw_def $id] if {[llength $deflist] == 0} { error "punk::args::parse - no such id: $id" @@ -3842,12 +4243,14 @@ tcl::namespace::eval punk::args { error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" } #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" } default { error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" } } try { + #puts stdout "parse --> get_dict $parseargs -form [dict get $opts -form]" set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] } trap {PUNKARGS VALIDATION} {msg erroropts} { set opt_errorstyle [dict get $opts -errorstyle] @@ -3974,46 +4377,347 @@ tcl::namespace::eval punk::args { #TODO } - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values - #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. - #only supports -flag val pairs, not solo options - #If an option is supplied multiple times - only the last value is used. - proc get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance + #return number of values we can assign to cater for variable length clauses such as {"elseif" expr "?then?" body} + #review - efficiency? each time we call this - we are looking ahead at the same info + proc _get_dict_can_assign_value {idx values nameidx names namesreceived formdict} { + set ARG_INFO [dict get $formdict ARG_INFO] + set all_remaining [lrange $values $idx end] + set thisname [lindex $names $nameidx] + set thistype [dict get $ARG_INFO $thisname -type] + set tailnames [lrange $names $nameidx+1 end] - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } + #todo - work backwards with any (optional or not) literals at tail that match our values - and remove from assignability. + set ridx 0 + foreach clausename [lreverse $tailnames] { + #puts "=============== clausename:$clausename all_remaining: $all_remaining" + set typelist [dict get $ARG_INFO $clausename -type] + if {[lsearch $typelist literal*] == -1} { + break } - } - + set max_clause_length [llength $typelist] + if {$max_clause_length == 1} { + #basic case + set alloc_ok 0 + #set v [lindex $values end-$ridx] + set v [lindex $all_remaining end] + set tp [lindex $typelist 0] + #review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead? + #we shouldn't have an optional clause member if there is only one member - the whole name should be marked -optional true instead. + set tp [string trim $tp ?] + foreach tp_member [split $tp |] { + if {[string match literal* $tp]} { + set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) + if {[string match (*) $litinfo]} { + set match [string range $litinfo 1 end-1] + } else { + #plain "literal" without bracketed specifier - match to argument name + set match $clausename + } + if {$v eq $match} { + set alloc_ok 1 + lpop all_remaining + if {![dict get $ARG_INFO $clausename -multiple]} { + lpop tailnames + } + #type (or one of the possible type alternates) matched a literal + break + } + } + } + if {!$alloc_ok} { + if {![dict get $ARG_INFO $clausename -optional]} { + break + } + } - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values - #[para]Returns a dict of the form: opts values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced - #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values - #[para]Each optionspec line defining a flag must be of the form: - #[para]-optionname -key val -key2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + } else { + #review - we assume here that we don't have a set of clause-members where all are marked optional (?membertype?) + #This is better caught during definition. + #e.g rn = {elseif expr (?then?) body} typelist = {literal expr ?literal? script} + #set cvals [lrange $values end-$ridx end-[expr {$ridx + $max_clause_length-1}]] + set cvals [lrange $values end-[expr {$ridx + $max_clause_length-1}] end-$ridx] + set rcvals [lreverse $cvals] + set alloc_count 0 + #clause name may have more entries than types - extras at beginning are ignored + set rtypelist [lreverse $typelist] + set rclausename [lrange [lreverse $clausename] 0 [llength $typelist]-1] + #assert length of rtypelist >= $rclausename + set alloc_ok 0 + set reverse_type_index 0 + #todo handle type-alternates + # for example: -type {string literal(x)|literal(y)} + foreach tp $rtypelist membername $rclausename { + #(membername may be empty if not enough elements) + #set rv [lindex $rcvals end-$alloc_count] + set rv [lindex $all_remaining end-$alloc_count] + if {[string match {\?*\?} $tp]} { + set clause_member_optional 1 + } else { + set clause_member_optional 0 + } + set tp [string trim $tp ?] + if {[string match literal* $tp]} { + set litinfo [string range $tp 7 end] + if {[string match (*) $litinfo]} { + set match [string range $litinfo 1 end-1] + } else { + #if membername empty - equivalent to "literal()" - matches empty string literal + #edgecase - possibly? no need for empty-string literals - but allow it without error. + set match $membername + } + #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 + } + } + } else { + if {$clause_member_optional} { + #review - optional non-literal makes things harder.. + #we don't want to do full type checking here - but we now risk allocating an item that should actually + #be allocated to the previous value + set prev_type [lindex $rtypelist $reverse_type_index+1] + if {[string match literal* $prev_type]} { + set litinfo [string range $prev_type 7 end] + #todo -literalprefix + if {[string match (*) $litinfo]} { + set match [string range $litinfo 1 end-1] + } else { + #prev membername + set match [lindex $rclausename $reverse_type_index+1] + } + if {$rv ne $match} { + #current val doesn't match previous type - allocate here + incr alloc_count + } + } else { + #no literal to anchor against.. + incr alloc_count + } + } else { + #allocate regardless of type - we're only matching on arity and literal positioning here. + #leave final type-checking for later. + incr alloc_count + } + } + incr reverse_type_index + } + if {$alloc_ok && $alloc_count > 0} { + #set n [expr {$alloc_count -1}] + #set all_remaining [lrange $all_remaining end-$n end] + set all_remaining [lrange $all_remaining 0 end-$alloc_count] + #don't lpop if -multiple true + if {![dict get $ARG_INFO $clausename -multiple]} { + lpop tailnames + } + } else { + break + } + } + incr ridx + } + 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 ?) + #thisname already satisfied, or not required + set tail_needs 0 + foreach t $tailnames { + if {![dict get $ARG_INFO $t -optional]} { + set min_clause_length [llength [lsearch -all -not [dict get $ARG_INFO $t -type] {\?*\?}]] + incr tail_needs $min_clause_length + } + } + set all_remaining [lrange $all_remaining 0 end-$tail_needs] + } + + #thistype + set alloc_ok 1 ;#default assumption only + set alloc_count 0 + set resultlist [list] + set n [expr {[llength $thistype]-1}] + #name can have more or less items than typelist + set thisnametail [lrange $thisname end-$n end] + set tpidx 0 + set newtypelist $thistype + foreach tp $thistype membername $thisnametail { + set v [lindex $all_remaining $alloc_count] + if {[string match {\?*\?} $tp]} { + set clause_member_optional 1 + } else { + set clause_member_optional 0 + } + set tp [string trim $tp ?] + + set member_satisfied 0 + + #----------------------------------------------------------------------------------- + #first build list of any literals - and whether any are literalprefix + set literals [list] + set literalprefixes [list] + set nonliterals [list] + set dict_member_match [dict create] + foreach tp_member [split $tp |] { + #JJJJ + if {[string match literal* $tp_member]} { + if {[string match literalprefix* $tp_member]} { + set litinfo [string range $tp_member 13 end] + if {[string match (*) $litinfo]} { + lappend literalprefixes [string range $litinfo 1 end-1] + } else { + lappend literalprefixes $membername + } + dict set dict_member_match $tp_member [lindex $literalprefixes end] + } else { + set litinfo [string range $tp_member 7 end] + if {[string match (*) $litinfo]} { + lappend literals [string range $litinfo 1 end-1] + } else { + lappend literals $membername + } + dict set dict_member_match $tp_member [lindex $literals end] + } + } else { + lappend nonliterals $tp_member + } + } + #----------------------------------------------------------------------------------- + #asert - each tp_member is a key in dict_member_match + if {[llength $nonliterals] > 0} { + #presence of any ordinary type as one of the alternates - means we consider it a match + #we don't validate here -leave validation for later (review) + set member_satisfied 1 + } else { + if {$v in $literals} { + set member_satisfied 1 + } else { + #literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed + #(exact match would have been caught in other branch of this if) + set full_v [tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $v] + if {$full_v ne "" && $full_v ni $literals} { + #matched prefix must be for one of the entries in literalprefixes - valid + set member_satisfied 1 + } + } + } + + #foreach tp_member [split $tp |] { + # if {[string match literal* $tp_member]} { + # #todo - support literal prefix-matching + # #e.g see ::readFile filename ?text|binary? - must accept something like readfile xxx.txt b + # set litinfo [string range $tp_member 7 end] + # if {[string match (*) $litinfo]} { + # set match [string range $litinfo 1 end-1] + # } else { + # set match $membername + # } + # set match [dict get $dict_member_match $tp_member] + # if {$v eq $match} { + # set member_satisfied 1 + # break + # } + # } else { + # #we don't validate here -leave validation for later (review) + # set member_satisfied 1 + # break + # } + #} + + if {$member_satisfied} { + if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { + if {[dict exists $ARG_INFO $thisname -typedefaults]} { + set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx] + lappend resultlist $d + lset newtypelist $tpidx ?defaulted-$tp? + } else { + lset newtypelist $tpidx ?omitted-$tp? + lappend resultlist "" + } + } else { + lappend resultlist $v + incr alloc_count + } + } else { + if {$clause_member_optional} { + if {[dict exists $ARG_INFO $thisname -typedefaults]} { + set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx] + lappend resultlist $d + lset newtypelist $tpidx ?defaulted-$tp? + } else { + lappend resultlist "" + lset newtypelist $tpidx ?omitted-$tp? + } + } else { + set alloc_ok 0 + } + } + + if {$alloc_count > [llength $all_remaining]} { + set alloc_ok 0 + break + } + incr tpidx + } + + #?omitted-*? and ?defaulted-*? in typelist are a way to know which elements in the clause were missing/defaulted + #so that they are not subject to type validation + #such elements shouldn't be subject to validation + if {$alloc_ok} { + set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] + } else { + set d [dict create consumed 0 resultlist {} typelist $thistype] + } + #puts ">>>> _get_dict_can_assign_value $d" + return $d + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional etc #[para]Each optionspec line defining a positional argument is of the form: #[para]argumentname -key val -ky2 val2... #[para]where the valid keys for each option specification are: -default -type -range -choices @@ -4092,8 +4796,18 @@ tcl::namespace::eval punk::args { set valmin 0 #set VAL_MIN 0 foreach v $VAL_NAMES { - if {[dict exists $ARG_INFO $v -optional] && ![dict get $ARG_INFO $v -optional]} { - incr valmin + if {![dict get $ARG_INFO $v -optional]} { + # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) + # e.g -types {a ?xxx?} + #this has one required and one optional + set typelist [dict get $ARG_INFO $v -type] + set clause_length 0 + foreach t $typelist { + if {![string match {\?*\?} $t]} { + incr clause_length + } + } + incr valmin $clause_length } } } else { @@ -4108,10 +4822,14 @@ tcl::namespace::eval punk::args { set all_opts [list] set lookup_optset [dict create] foreach optset $OPT_NAMES { + #optset e.g {-x|--longopt|--longopt=|--otherlongopt} set optmembers [split $optset |] - lappend all_opts {*}$optmembers - foreach opt $optmembers { - dict set lookup_optset $opt $optset + foreach optdef $optmembers { + set opt [string trimright $optdef =] + if {$opt ni $all_opts} { + dict set lookup_optset $opt $optset + lappend all_opts $opt + } } } set ridx 0 @@ -4120,17 +4838,31 @@ tcl::namespace::eval punk::args { 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) + + + #consider for example: LEADER_NAMES {"k v" leader2 leader3} with -type {int number} & -type {int int int} & -type string + #(i.e clause-length 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 + #REVIEW - what about optional members in leaders e.g -type {int ?double?} set named_leader_args_max 0 foreach ln $LEADER_NAMES { - incr named_leader_args_max [llength $ln] + set typelist [dict get $ARG_INFO $ln -type] + incr named_leader_args_max [llength $typelist] } + + #set id [dict get $argspecs id] + #if {$id eq "::if"} { + #puts stderr "::if" + #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" + #} + + + #REVIEW - this attempt to classify leaders vs opts vs values doesn't account for leaders with clauses containing optional elements + #e.g @leadrs {x -type {int ?int?}} set nameidx 0 if {$LEADER_MAX != 0} { for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { - set r [lindex $rawargs $ridx] + set raw [lindex $rawargs $ridx] ;#received raw arg if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { break } @@ -4148,41 +4880,34 @@ tcl::namespace::eval punk::args { } else { 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) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $all_opts $r] + if {$OPT_MAX ne "0"} { + #all_opts includes end_of_opts marker -- if configured - no need to explicitly check for it separately + set flagname $raw + if {[string match --* $raw]} { + set eposn [string first = $raw] + # --flag=xxx + if {$eposn >=3} { + set flagname [string range $raw 0 $eposn-1] + } + } + set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] if {$matchopt ne ""} { #flaglike matches a known flag - don't treat as leader break } - 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 - 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 - continue - } else { - break - } } #for each branch - break or lappend if {$leader_posn_name ne ""} { - set stridelength [llength $leader_posn_name] + set leader_type [dict get $ARG_INFO $leader_posn_name -type] + #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" + set clauselength [llength $leader_type] + set min_clauselength 0 + foreach t $leader_type { + if {![string match {\?*\?} $t]} { + incr min_clauselength + } + } if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader @@ -4192,7 +4917,7 @@ 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 $remaining_rawargs 0]] + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] $raw] # 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 remaining_rawargs 0] @@ -4200,52 +4925,99 @@ tcl::namespace::eval punk::args { # continue # } #} - if {[llength $remaining_rawargs] < $stridelength} { + if {[llength $remaining_rawargs] < $min_clauselength} { #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 remaining_rawargs to fill any required values - if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength < $valmin} { + if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { break } - #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] + #leadername may be a 'clause' of arbitrary length (e.g -type {int double} or {int string number}) + set end_leaders 0 + foreach t $leader_type { + set raw [lindex $rawargs $ridx] + if {[string match {\?*\?} $t] && [string match -* $raw]} { + #review - limitation of optional leaders is they can't be same value as any defined flags/opts + set flagname $raw + if {[string match --* $raw]} { + set eposn [string first = $raw] + # --flag=xxx + if {$eposn >=3} { + set flagname [string range $raw 0 $eposn-1] + } + } + set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] + if {$matchopt ne ""} { + #don't consume if flaglike (and actually matches an opt) + set end_leaders 1 + break ;#break out of looking at -type members in the clause + } else { + #unrecognised flag - treat as value for optional member of the clause + lappend pre_values [lpop remaining_rawargs 0] + incr ridx + } + } else { + lappend pre_values [lpop remaining_rawargs 0] + incr ridx + } + } + incr ridx -1 ;#leave ridx at index of last r that we set + if {$end_leaders} { + break } if {!$is_multiple} { incr nameidx } dict incr leader_posn_names_assigned $leader_posn_name } else { - #required + #clause is required if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {[llength $remaining_rawargs] < $stridelength} { + #already accepted at least one complete clause for this name - requirement satisfied - now equivalent to optional + if {[llength $remaining_rawargs] < $min_clauselength} { #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} { + if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $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} { + if {[llength $remaining_rawargs] < $min_clauselength} { #not enough remaining args to fill *required* leader break } + set end_leaders 0 + foreach t $leader_type { + set raw [lindex $rawargs $ridx] + if {[string match {\?*\?} $t] && [string match -* $raw]} { + #review - limitation of optional leaders is they can't be same value as any defined flags/opts + + set matchopt [::tcl::prefix::match -error {} $all_opts $raw] + if {$matchopt ne ""} { + #don't consume if flaglike (and actually matches an opt) + set end_leaders 1 + break ;#break out of looking at -type members in the clause + } else { + #unrecognised flag - treat as value for optional member of the clause + lappend pre_values [lpop remaining_rawargs 0] + incr ridx + } + } else { + lappend pre_values [lpop remaining_rawargs 0] + incr ridx + } + } incr ridx -1 - foreach v $leader_posn_name { - incr ridx - lappend pre_values [lpop remaining_rawargs 0] + if {$end_leaders} { + break } if {!$is_multiple} { incr nameidx @@ -4285,6 +5057,7 @@ tcl::namespace::eval punk::args { #incr ridx } ;# end foreach r $rawargs_copy } + #puts "get_dict ================> pre: $pre_values" set argstate $ARG_INFO ;#argstate may have entries added set arg_checks $ARG_CHECKS @@ -4310,7 +5083,12 @@ tcl::namespace::eval punk::args { #assert - remaining_rawargs has been reduced by leading positionals set opts [dict create] ;#don't set to OPT_DEFAULTS here -#JJJ + #set id [dict get $argspecs id] + #if {$id eq "::if"} { + #puts stderr "::if" + #puts stderr "get_dict--> pre_values: $pre_values" + #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" + #} set leaders [list] set arglist {} @@ -4318,8 +5096,8 @@ tcl::namespace::eval punk::args { #valmin, valmax #puts stderr "remaining_rawargs: $remaining_rawargs" #puts stderr "argstate: $argstate" - if {[lsearch $remaining_rawargs -*] >= 0} { - #at least contains flaglike things.. + if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { + #contains at least one possible flag set maxidx [expr {[llength $remaining_rawargs] -1}] if {$valmax == -1} { set vals_total_possible [llength $remaining_rawargs] @@ -4329,7 +5107,6 @@ tcl::namespace::eval punk::args { set vals_remaining_possible $vals_total_possible } for {set i 0} {$i <= $maxidx} {incr 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} { @@ -4338,74 +5115,197 @@ tcl::namespace::eval punk::args { set post_values [lrange $remaining_rawargs $i end] break } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + set a [lindex $remaining_rawargs $i] + #if {$a eq "--"} { + # #REVIEW + # #remaining num args <= valmin already covered above + # if {$valmax != -1} { + # #finite max number of vals + # if {$remaining_args_including_this == $valmax} { + # #assume it's a value. + # 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 $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 $remaining_rawargs 0 $i] + # set post_values [lrange $remaining_rawargs $i+1 end] + # } + # break + #} + if {[string match --* $a]} { if {$a eq "--"} { - #remaining num args <= valmin already covered above - if {$valmax != -1} { - #finite max number of vals - if {$remaining_args_including_this == $valmax} { - #assume it's a value. - 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 $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted + if {$a in $OPT_NAMES} { #treat this as eopts - we don't care if remainder look like options or not lappend flagsreceived -- set arglist [lrange $remaining_rawargs 0 $i] set post_values [lrange $remaining_rawargs $i+1 end] + } else { + #assume it's a value. + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] } break } else { - 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] + set eposn [string first = $a] + if {$eposn > 2} { + #only allow longopt-style = for double leading dash longopts + #--*= usage + if {$flagname ni $raw_optionset_members} { + # + set msg "Bad options for %caller%. Option $optionset at index [expr {$i-1}] requires a value, but '$flagname' not specified in definition to allow space-separated value." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list badoptionformat $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg + } } - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo + if {$solo_only} { + #same logic as 'solo' branch below for -type none + if {[tcl::dict::get $argstate $optionset -multiple]} { + if {$api_opt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $api_opt 1 + } else { + tcl::dict::lappend opts $api_opt 1 + } + if {$api_opt ni $multisreceived} { + lappend multisreceived $api_opt + } + } else { + tcl::dict::set opts $api_opt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $api_opt ;#dups ok + } else { #check if it was actually a value that looked like a flag if {$i == $maxidx} { #if no optvalue following - assume it's a value #(caller should probably have used -- before it) + #review set arglist [lrange $remaining_rawargs 0 $i-1] set post_values [lrange $remaining_rawargs $i end] break } - + #flagval comes from next remaining rawarg set flagval [lindex $remaining_rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {[tcl::dict::get $argstate $optionset -multiple]} { #don't lappend to default - we need to replace if there is a default if {$api_opt ni $flagsreceived} { tcl::dict::set opts $api_opt [list $flagval] @@ -4421,55 +5321,86 @@ tcl::namespace::eval punk::args { #incr i to skip flagval incr vals_remaining_possible -2 if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + set msg "Bad options for %caller%. No value supplied for last option $optionset at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg } + } + } + } else { + #solo + if {[tcl::dict::get $argstate $optionset -multiple]} { + if {$api_opt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $api_opt 1 } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $api_opt 1 - } else { - tcl::dict::lappend opts $api_opt 1 - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $fullopt + tcl::dict::lappend opts $api_opt 1 + } + if {$api_opt ni $multisreceived} { + lappend multisreceived $api_opt + } + } else { + tcl::dict::set opts $api_opt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $api_opt ;#dups ok + } + lappend flagsreceived $api_opt ;#dups ok + } else { + #starts with - but unmatched option flag + #comparison to valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even if 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 $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$OPT_ANY} { + #exlude argument with whitespace from being a possible option e.g dict + #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value + set eposn [string first = $a] + if {[string match --* $a] && $eposn > 2} { + #only allow longopt-style = for double leading dash longopts + #--*= $maxidx} { set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" @@ -4494,24 +5425,26 @@ tcl::namespace::eval punk::args { incr vals_remaining_possible -1 lappend solosreceived $a } - lappend flagsreceived $a ;#adhoc flag as supplied + } + + lappend flagsreceived $flagreceived ;#adhoc flag name (if --x=1 -> --x) + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES (3)" } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any|-arbitrary false" } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $optionset } + } else { + #not a flag/option + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break } - } else { - #not flaglike - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break } + } #set values [list {*}$pre_values {*}$post_values] set leaders $pre_values @@ -4522,13 +5455,21 @@ tcl::namespace::eval punk::args { #set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected set arglist [list] } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" + #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" + #} #--------------------------------------- set ordered_opts [dict create] - 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) + 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] @@ -4536,7 +5477,7 @@ tcl::namespace::eval punk::args { dict set ordered_opts $o [dict get $OPT_DEFAULTS $optset] } } - #add in possible '-any true' opts after the defined opts + #add in possible arbitrary opts after the defined opts, due to @opts directive flag '-any|-arbitrary true' dict for {o oval} $opts { if {![dict exists $ordered_opts $o]} { dict set ordered_opts $o $oval @@ -4551,8 +5492,9 @@ tcl::namespace::eval punk::args { set leadernames_received [list] set num_leaders [llength $leaders] + #---------------------------------------- - #set leaders_dict $LEADER_DEFAULTS ;#wrong + #Establish firm leaders ordering set leaders_dict [dict create] foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { dict set leaders_dict $lname {} @@ -4562,101 +5504,118 @@ tcl::namespace::eval punk::args { set start_position $positionalidx set nameidx 0 - #MAINTENANCE - same loop logic as for values + #MAINTENANCE - (*nearly*?) same loop logic as for value for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { - set leadername [lindex $LEADER_NAMES $nameidx] - incr nameidx - set ldr [lindex $leaders $ldridx] + set leadername [lindex $LEADER_NAMES $nameidx] + set ldr [lindex $leaders $ldridx] if {$leadername ne ""} { - if {[llength $leadername] == 1} { - set strideval $ldr + set leadertypelist [tcl::dict::get $argstate $leadername -type] + + set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict] + set consumed [dict get $assign_d consumed] + set resultlist [dict get $assign_d resultlist] + set newtypelist [dict get $assign_d typelist] + if {[tcl::dict::get $argstate $leadername -optional]} { + if {$consumed == 0} { + #error 111 + incr ldridx -1 + set leadername_multiple "" + incr nameidx + continue + } } 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 + #required named arg + if {$consumed == 0} { + if {$leadername ni $leadernames_received} { + #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" + set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredleader $leadername ] -argspecs $argspecs]] $msg + } else { + #error 222 + incr ldridx -1 + set leadername_multiple "" + incr nameidx + continue } - lappend strideval [lindex $leaders $ldridx] } } + if {[llength $leadertypelist] == 1} { + set clauseval $ldr + } else { + set clauseval $resultlist + incr ldridx [expr {$consumed - 1}] + tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries + } + if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - #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 + #if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + # #current stored ldr equals defined default - don't include default in the list we build up + # tcl::dict::set leaders_dict $leadername [list $clauseval] ;#important to treat first element as a list + #} else { + # tcl::dict::lappend leaders_dict $leadername $clauseval + #} + if {$leadername in $leadernames_received} { + tcl::dict::lappend leaders_dict $leadername $clauseval } else { - tcl::dict::lappend leaders_dict $leadername $strideval + tcl::dict::set leaders_dict $leadername [list $clauseval] } set leadername_multiple $leadername } else { - tcl::dict::set leaders_dict $leadername $strideval + tcl::dict::set leaders_dict $leadername $clauseval + set leadername_multiple "" + incr nameidx } lappend leadernames_received $leadername } else { if {$leadername_multiple ne ""} { - if {[llength $leadername_multiple] == 1} { - set strideval $ldr + set leadertypelist [tcl::dict::get $argstate $leadername_multiple -type] + if {[llength $leadertypelist] == 1} { + set clauseval $ldr } else { - set strideval [list] + set clauseval [list] incr ldridx -1 - foreach v $leadername_multiple { + foreach t $leadertypelist { 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 + set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername_multiple', but requires up to [llength $leadertypelist] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadertypelist] ] -argspecs $argspecs]] $msg } - lappend strideval [lindex $leaders $ldridx] + lappend clauseval [lindex $leaders $ldridx] } } - tcl::dict::lappend leaders_dict $leadername_multiple $strideval + tcl::dict::lappend leaders_dict $leadername_multiple $clauseval #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 arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx + if {$LEADER_UNNAMED} { + 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 + } else { + 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 + } } } 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 - #} - + #----------------------------------------------------- + #satisfy test parse_withdef_leaders_no_phantom_default + foreach leadername [dict keys $leaders_dict] { + if {[string is integer -strict $leadername]} { + #ignore leadername that is a positionalidx + #review - always trailing - could use break? + continue + } + if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { + #remove the name with empty-string default we used to establish fixed order of names + #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. + dict unset leaders_dict $leadername + } + } + #----------------------------------------------------- set validx 0 set valname_multiple "" @@ -4664,79 +5623,140 @@ tcl::namespace::eval punk::args { set num_values [llength $values] #------------------------------------------ - #!!! review + #Establish firm values ordering ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults ## set values_dict $val_defaults set values_dict [dict create] foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + #set ALL valnames to lock in positioning + #note - later we need to unset any optional that had no default and was not received (no phantom default) dict set values_dict $valname {} } set values_dict [dict merge $values_dict $VAL_DEFAULTS] #------------------------------------------ set nameidx 0 set start_position $positionalidx - #MAINTENANCE - same loop logic as for leaders + #MAINTENANCE - (*nearly*?) same loop logic as for leaders for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - incr nameidx - set val [lindex $values $validx] + set valname [lindex $VAL_NAMES $nameidx] + set val [lindex $values $validx] if {$valname ne ""} { - if {[llength $valname] == 1} { - set strideval $val + set valtypelist [tcl::dict::get $argstate $valname -type] + + set assign_d [_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] + set consumed [dict get $assign_d consumed] + set resultlist [dict get $assign_d resultlist] + set newtypelist [dict get $assign_d typelist] + if {[tcl::dict::get $argstate $valname -optional]} { + if {$consumed == 0} { + incr validx -1 + set valname_multiple "" + incr nameidx + continue + } } else { - set strideval [list] - incr validx -1 - foreach v $valname { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + #required named arg + if {$consumed == 0} { + if {$valname ni $valnames_received} { + #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" + set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -argspecs $argspecs]] $msg + } else { + incr validx -1 + set valname_multiple "" + incr nameidx + continue } - lappend strideval [lindex $values $validx] } } + #assert can_assign != 0, we have at least one value to assign to clause + + if {[llength $valtypelist] == 1} { + set clauseval $val + } else { + #clauseval must contain as many elements as the max length of -types! + #(empty-string/default for optional (?xxx?) clause members) + set clauseval $resultlist + #_get_dict_can_assign has only validated clause-length and literals match + #we assign and leave further validation for main validation loop. + incr validx [expr {$consumed -1}] + if {$validx > [llength $values]-1} { + error "get_dict unreachable" + set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to [llength $valtypelist] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg + } + + tcl::dict::set argstate $valname -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries + } if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + #if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + # #current stored val equals defined default - don't include default in the list we build up + # tcl::dict::set values_dict $valname [list $clauseval] ;#important to treat first element as a list + #} else { + # tcl::dict::lappend values_dict $valname $clauseval + #} + if {$valname in $valnames_received} { + tcl::dict::lappend values_dict $valname $clauseval } else { - tcl::dict::lappend values_dict $valname $strideval + tcl::dict::set values_dict $valname [list $clauseval] } set valname_multiple $valname } else { - tcl::dict::set values_dict $valname $strideval + tcl::dict::set values_dict $valname $clauseval + set valname_multiple "" + incr nameidx } lappend valnames_received $valname } else { if {$valname_multiple ne ""} { + set valtypelist [tcl::dict::get $argstate $valname_multiple -type] if {[llength $valname_multiple] == 1} { - set strideval $val + set clauseval $val } else { - set strideval [list] + set clauseval [list] incr validx -1 - foreach v $valname_multiple { + for {set i 0} {$i < [llength $valtypelist]} {incr i} { incr validx if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname_multiple', but requires [llength $valtypelist] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg } - lappend strideval [lindex $values $validx] + lappend clauseval [lindex $values $validx] } } - tcl::dict::lappend values_dict $valname_multiple $strideval + tcl::dict::lappend values_dict $valname_multiple $clauseval #name already seen - but must add to valnames_received anyway (as with opts and leaders) lappend valnames_received $valname_multiple } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx + if {$VAL_UNNAMED} { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } else { + 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 + } } } set positionalidx [expr {$start_position + $validx + 1}] } - #------------------------------------------ + #----------------------------------------------------- + #satisfy test parse_withdef_values_no_phantom_default + foreach vname [dict keys $values_dict] { + if {[string is integer -strict $vname]} { + #ignore vname that is a positionalidx + #review - always trailing - could break? + continue + } + if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { + #remove the name with empty-string default we used to establish fixed order of names + #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. + dict unset values_dict $vname + } + } + #----------------------------------------------------- if {$leadermax == -1} { #only check min @@ -4774,11 +5794,11 @@ tcl::namespace::eval punk::args { } } - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + #assertion - opts keys are full-length option names if -any|-arbitrary was false or if the supplied option as a shortname matched one of our defined options - #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) - #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #opts explicitly marked as -optional 0 must be present - regardless of -any|-arbitrary (which allows us to ignore additional opts to pass on to next call) + #however - if -any|-arbitrary is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level @@ -4813,6 +5833,23 @@ tcl::namespace::eval punk::args { #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs } + #--------------------------------------------------------------------------------------------- + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + #--------------------------------------------------------------------------------------------- + #todo - truncate/summarize values in error messages @@ -4823,14 +5860,19 @@ tcl::namespace::eval punk::args { #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash #puts "---opts_and_values:$opts_and_values" #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - if {[string match -* $argname]} { + tcl::dict::for {api_argname value_group} $opts_and_values { + if {[string match -* $api_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] + #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined + if {[dict exists $lookup_optset $api_argname]} { + set argname [dict get $lookup_optset $api_argname] + } else { + puts stderr "unable to find $api_argname in $lookup_optset" } + } else { + set argname $api_argname } + set thisarg [tcl::dict::get $argstate $argname] #set thisarg_keys [tcl::dict::keys $thisarg] set thisarg_checks [tcl::dict::get $arg_checks $argname] @@ -4842,17 +5884,22 @@ tcl::namespace::eval punk::args { if {$has_default} { set defaultval [tcl::dict::get $thisarg -default] } - set type [tcl::dict::get $thisarg -type] + set typelist [tcl::dict::get $thisarg -type] set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] set regexprepass [tcl::dict::get $thisarg -regexprepass] set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 set validationtransform [tcl::dict::get $thisarg -validationtransform] + #JJJJ if {$is_multiple} { - set vlist $v + set vlist $value_group } else { - set vlist [list $v] + set vlist [list $value_group] + } + #JJJJ + if {[llength $typelist] == 1} { + set vlist [list $vlist] } set vlist_original $vlist ;#retain for possible final strip_ansi @@ -4861,8 +5908,8 @@ tcl::namespace::eval punk::args { #validate_ansistripped 1 package require punk::ansi set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] + foreach clause_value $vlist { + lappend vlist_check [punk::ansi::ansistrip $clause_value] } } else { #validate_ansistripped 0 @@ -4889,18 +5936,19 @@ tcl::namespace::eval punk::args { } #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$has_choices} { + if {$api_argname in $receivednames && $has_choices} { #-choices must also work with -multiple #todo -choicelabels set choiceprefix [tcl::dict::get $thisarg -choiceprefix] set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}] set choicerestricted [tcl::dict::get $thisarg -choicerestricted] set choicemultiple [tcl::dict::get $thisarg -choicemultiple] if {[string is integer -strict $choicemultiple]} { set choicemultiple [list $choicemultiple $choicemultiple] } lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] + set nocase [tcl::dict::get $thisarg -nocase] set choices [Dict_getdef $thisarg -choices {}] set choicegroups [Dict_getdef $thisarg -choicegroups {}] set allchoices $choices @@ -4984,6 +6032,7 @@ tcl::namespace::eval punk::args { #assert chosen will always get set set choice_in_list 1 } else { + #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. #in this block we can treat empty result from prefix match as a non-match @@ -4998,9 +6047,9 @@ tcl::namespace::eval punk::args { #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] + if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { + set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing set chosen [lsearch -inline -nocase $allchoices $chosen] set choice_in_list [expr {$chosen ne ""}] @@ -5009,8 +6058,8 @@ tcl::namespace::eval punk::args { set choice_in_list 1 } } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { + set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] + if {$chosen eq "" || $chosen in $choiceprefixreservelist} { set choice_in_list 0 } else { set choice_in_list 1 @@ -5089,18 +6138,43 @@ tcl::namespace::eval punk::args { set vlist_check $vlist_check_validate } - if {[llength $vlist] && $has_default} { - set vlist_validate [list] + #todo - don't add to validation lists if not in receivednames + #if we have an optionset such as "-f|-x|-etc" api_argname is -etc + if {$api_argname ni $receivednames} { + set vlist [list] set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c + } else { + if {[llength $vlist] && $has_default} { + #defaultval here is a value for the clause. + set vlist_validate [list] + set vlist_check_validate [list] + foreach clause_value $vlist clause_check $vlist_check { + #JJJJ + #argname + #thisarg + set tp [dict get $thisarg -type] + if {[llength $tp] == 1} { + if {$clause_value ni $vlist_validate} { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {[lindex $clause_check 0] ne $defaultval} { + lappend vlist_validate $clause_value + lappend vlist_check_validate $clause_check + } + } + } else { + if {$clause_value ni $vlist_validate} { + if {$clause_check ne $defaultval} { + lappend vlist_validate $clause_value + lappend vlist_check_validate $clause_check + } + } + } + #Todo? + #else ??? } + set vlist $vlist_validate + set vlist_check $vlist_check_validate } - set vlist $vlist_validate - set vlist_check $vlist_check_validate } #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups @@ -5109,10 +6183,12 @@ tcl::namespace::eval punk::args { #allow_ansi 0 package require punk::ansi #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + foreach clause_value $vlist { + foreach e $clause_value { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } } } } @@ -5129,37 +6205,44 @@ tcl::namespace::eval punk::args { #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups #assert [llength $vlist] == [llength $vlist_check] if {[llength $vlist]} { - switch -- $type { - literal { - foreach e $vlist { - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + for {set t 0} {$t < [llength $typelist]} {incr t} { + set typespec [lindex $typelist $t] + set type [string trim $typespec ?] + #puts "$argname - switch on type: $type" + switch -- $type { + any {} + literal { + foreach clause_value $vlist { + set e [lindex $clause_value $t] + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } } } - } - any {} - list { - foreach e_check $vlist_check { - 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 + list { + foreach clause_value $vlist_check { + set e_check [lindex $clause_value $t] + 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 + -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 + } } } } @@ -5167,216 +6250,187 @@ tcl::namespace::eval punk::args { } } } - } - indexexpression { - foreach e_check $vlist_check { - 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 + indexexpression { + foreach clause_value $vlist_check { + set e_check [lindex $clause_value $t] + 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 - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check + 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 + if {$regexprepass ne ""} { + foreach clauseval $vlist clauseval_check $vlist_check { + set e [lindex $clauseval $t] + set e_check [lindex $clauseval_check $t] + if {[regexp [lindex $regexprepass $t] $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] } - 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 e $remaining_e e_check $remaining_e_check { - #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'" + if {$regexprefail ne ""} { + foreach clauseval $remaining_e clauseval_check $remaining_e_check { + set e [lindex $clauseval $t] + set e_check [lindex $clauseval_check $t] + #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 } - 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 e $remaining_e { - 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 + 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 $t] + 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 e $remaining_e { - 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 + globstring { + foreach clauseval $remaining_e { + set e [lindex $clauseval $t] + 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 e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. 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 {[tcl::dict::size $thisarg_checks]} { + foreach clauseval $remaining_e_check { + set e_check [lindex $clauseval $t] + 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 } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. 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) - lassign {} low high ;#set both empty - set has_range 0 - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - set has_range 1 - } - } - foreach e $vlist e_check $vlist_check { - 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 {$has_range} { - 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 - } + 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 $t] + 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 } } - } - } - int { - #-range 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 - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #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 ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #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'" + if {[tcl::dict::exists $thisarg -typeranges]} { + set ranges [tcl::dict::get $thisarg -typeranges] + foreach clauseval $vlist clauseval_check $vlist_check { + set e [lindex $clauseval $t] + set e_check [lindex $clauseval_check $t] + set range [lindex $ranges $t] + 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 } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #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 + 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 + } } } } } - } else { - foreach e_check $vlist_check { + } + 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 $t] 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 } } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - 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]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high + if {[tcl::dict::exists $thisarg -typeranges]} { + set ranges [tcl::dict::get $thisarg -typeranges] + foreach clauseval $vlist clauseval_check $vlist_check { + set e [lindex $clauseval $t] + set e_check [lindex $clauseval_check $t] + set range [lindex $ranges $t] + 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 double between $low and $high. Received: '$e'" + 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 } } @@ -5384,103 +6438,144 @@ tcl::namespace::eval punk::args { } } } - } - bool { - foreach e_check $vlist_check { - 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 + double { + foreach clauseval $vlist clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $t] + if {![tcl::string::is double -strict $e_check]} { + set e [lindex $clauseval $t] + 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 $t] + set range [lindex $ranges $t] + #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 $t] + 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 + } + } + } } } - } - dict { - foreach e_check $vlist_check { - 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 + bool { + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $t] + 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 $t] + 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]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } + if {[dict exists $thisarg_checks -minsize]} { + set minsizes [dict get $thisarg_checks -minsize] + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $t] + set minsize [lindex $minsizes $t] + # -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 } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -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 $t] + set maxsize [lindex $maxsizes $t] + 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 e $vlist e_check $vlist_check { - if {![tcl::string::is $type -strict $e_check]} { - 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 e $vlist e_check $vlist_check { - #//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 + 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 $t] + 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 + } } } - if {$type eq "existingfile"} { + file - + directory - + existingfile - + existingdirectory { foreach e $vlist e_check $vlist_check { - 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 + #//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 } } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - 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 + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + 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"} { + foreach e $vlist e_check $vlist_check { + 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 e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - 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 + char { + #review - char vs unicode codepoint vs grapheme? + foreach clauseval $vlist clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $t] + if {[tcl::string::length $e_check] != 1} { + set e [lindex $clauseval $t] + 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 + } } } } + } + } if {$is_strip_ansi} { @@ -5513,20 +6608,6 @@ tcl::namespace::eval punk::args { } } - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] } @@ -5620,21 +6701,115 @@ tcl::namespace::eval punk::args { dict set SYND $f [list] append syn "$id" set forminfo [dict get $spec FORMS $f] + #foreach argname [dict get $forminfo LEADER_NAMES] { + # set arginfo [dict get $forminfo ARG_INFO $argname] + # set ARGD [dict create argname $argname class leader] + # if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + # set display [lindex [dict get $arginfo -choices] 0] + # } elseif {[dict get $arginfo -type] eq "literal"} { + # set display $argname + # } else { + # set display $I$argname$RST + # } + # if {[dict get $arginfo -optional]} { + # append syn " ?$display?" + # } else { + # append syn " $display" + # } + # dict set ARGD type [dict get $arginfo -type] + # dict set ARGD optional [dict get $arginfo -optional] + # dict set ARGD display $display + # dict lappend SYND $f $ARGD + #} foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class leader] - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display [lindex [dict get $arginfo -choices] 0] - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname + set arginfo [dict get $forminfo ARG_INFO $argname] + set typelist [dict get $arginfo -type] + if {[llength $typelist] == 1} { + set tp [lindex $typelist 0] + if {[dict exists $arginfo -typesynopsis]} { + set arg_display [dict get $arginfo -typesynopsis] + } else { + set arg_display $argname + } + if {$tp eq "literal"} { + set clause [lindex $argname end] + } elseif {[string match literal(*) $tp]} { + set match [string range $tp 8 end-1] + set clause $match + } else { + set clause $I$arg_display$RST + } } else { - set display $I$argname$RST + set n [expr {[llength $typelist]-1}] + set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types + set clause "" + if {[dict exists $arginfo -typesynopsis]} { + set tp_displaylist [dict get $arginfo -typesynopsis] + } else { + set tp_displaylist [lrepeat [llength $typelist] ""] + } + + foreach typespec $typelist td $tp_displaylist elementname $name_tail { + #elementname will commonly be empty + if {[string match {\?*\?} $typespec]} { + set tp [string range $typespec 1 end-1] + set member_optional 1 + } else { + set tp $typespec + set member_optional 0 + } + if {$tp eq "literal"} { + set c $elementname + } elseif {[string match literal(*) $tp]} { + set match [string range $tp 8 end-1] + set c $match + } else { + if {$td eq ""} { + set c $I$tp$RST + } else { + set c $I$td$RST + } + } + if {$member_optional} { + append clause " " "(?$c?)" + } else { + append clause " " $c + } + } + set clause [string trimleft $clause] } - if {[dict get $arginfo -optional]} { - append syn " ?$display?" + + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + #set display "?$I$argname$RST?..." + set display "?$clause?..." + } else { + set display "?$clause?" + #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + # set display "?[lindex [dict get $arginfo -choices] 0]?" + #} elseif {[dict get $arginfo -type] eq "literal"} { + # set display "?$argname?" + #} else { + # set display "?$I$argname$RST?" + #} + } } else { - append syn " $display" + if {[dict get $arginfo -multiple]} { + #set display "$I$argname$RST ?$I$argname$RST?..." + set display "$clause ?$clause?..." + } else { + set display $clause + #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + # set display "[lindex [dict get $arginfo -choices] 0]" + #} elseif {[dict get $arginfo -type] eq "literal"} { + # set display $argname + #} else { + # set display "$I$argname$RST" + #} + } } + append syn " $display" dict set ARGD type [dict get $arginfo -type] dict set ARGD optional [dict get $arginfo -optional] dict set ARGD display $display @@ -5644,18 +6819,23 @@ tcl::namespace::eval punk::args { set arginfo [dict get $forminfo ARG_INFO $argname] set ARGD [dict create argname $argname class option] set tp [dict get $arginfo -type] + if {[dict exists $arginfo -typesynopsis]} { + set tp_display [dict get $arginfo -typesynopsis] + } else { + set tp_display "<$tp>" + } if {[dict get $arginfo -optional]} { if {[dict get $arginfo -multiple]} { if {$tp eq "none"} { set display "?$argname?..." } else { - set display "?$argname <$tp>?..." + set display "?$argname $tp_display?..." } } else { if {$tp eq "none"} { set display "?$argname?" } else { - set display "?$argname <$tp>?" + set display "?$argname $tp_display?" } } } else { @@ -5663,13 +6843,13 @@ tcl::namespace::eval punk::args { if {$tp eq "none"} { set display "$argname ?$argname...?" } else { - set display "$argname <$tp> ?$argname <$tp>?..." + set display "$argname $tp_display ?$argname $tp_display?..." } } else { if {$tp eq "none"} { set display $argname } else { - set display "$argname <$tp>" + set display "$argname $tp_display" } } } @@ -5680,32 +6860,111 @@ tcl::namespace::eval punk::args { dict lappend SYND $f $ARGD } foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - set display "?$I$argname$RST?..." + set arginfo [dict get $forminfo ARG_INFO $argname] + set typelist [dict get $arginfo -type] + if {[llength $typelist] == 1} { + set tp [lindex $typelist 0] + if {[dict exists $arginfo -typesynopsis]} { + set arg_display [dict get $arginfo -typesynopsis] } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "?[lindex [dict get $arginfo -choices] 0]?" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display "?$argname?" + set arg_display $argname + } + set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) + foreach tp_member [split $tp |] { + if {$tp_member eq "literal"} { + lappend alternates [lindex $argname end] + } elseif {[string match literal(*) $tp_member]} { + set match [string range $tp_member 8 end-1] + lappend alternates $match + } elseif {[string match literalprefix(*) $tp_member]} { + set match [string range $tp_member 14 end-1] + lappend alternates $match } else { - set display "?$I$argname$RST?" + lappend alternates $I$arg_display$RST } } + #remove dupes - but keep order (e.g of dupes -type string|int when no -typesynopsis was specified) + #todo - trie prefixes display + set alternates [punk::args::lib::lunique $alternates] + set clause [join $alternates |] } else { - if {[dict get $arginfo -multiple]} { - set display "$I$argname$RST ?$I$argname$RST?..." + set n [expr {[llength $typelist]-1}] + set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types + set clause "" + if {[dict exists $arginfo -typesynopsis]} { + set tp_displaylist [dict get $arginfo -typesynopsis] } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "[lindex [dict get $arginfo -choices] 0]" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname + set tp_displaylist [lrepeat [llength $typelist] ""] + } + + foreach typespec $typelist td $tp_displaylist elementname $name_tail { + #elementname will commonly be empty + if {[string match {\?*\?} $typespec]} { + set tp [string range $typespec 1 end-1] + set member_optional 1 + } else { + set tp $typespec + set member_optional 0 + } + #handle alternate-types e.g literal(text)|literal(binary) + set alternates [list] + foreach tp_member [split $tp |] { + if {$tp_member eq "literal"} { + lappend alternates $elementname + } elseif {[string match literal(*) $tp_member]} { + set match [string range $tp_member 8 end-1] + lappend alternates $match + } elseif {[string match literalprefix(*) $tp_member]} { + set match [string range $tp_member 14 end-1] + lappend alternates $match + } else { + if {$td eq ""} { + lappend alternates $I$tp$RST + } else { + lappend alternates $I$td$RST + } + } + } + set alternates [punk::args::lib::lunique $alternates] + set c [join $alternates |] + if {$member_optional} { + append clause " " "(?$c?)" } else { - set display "$I$argname$RST" + append clause " " $c } } + set clause [string trimleft $clause] + } + + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + #set display "?$I$argname$RST?..." + set display "?$clause?..." + } else { + set display "?$clause?" + #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + # set display "?[lindex [dict get $arginfo -choices] 0]?" + #} elseif {[dict get $arginfo -type] eq "literal"} { + # set display "?$argname?" + #} else { + # set display "?$I$argname$RST?" + #} + } + } else { + if {[dict get $arginfo -multiple]} { + #set display "$I$argname$RST ?$I$argname$RST?..." + set display "$clause ?$clause?..." + } else { + set display $clause + #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + # set display "[lindex [dict get $arginfo -choices] 0]" + #} elseif {[dict get $arginfo -type] eq "literal"} { + # set display $argname + #} else { + # set display "$I$argname$RST" + #} + } } append syn " $display" dict set ARGD type [dict get $arginfo -type] @@ -6452,6 +7711,18 @@ tcl::namespace::eval punk::args::lib { return $prefix } + #order-preserving + #(same as punk::lib) + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] diff --git a/src/modules/punk/args-buildversion.txt b/src/modules/punk/args-buildversion.txt index f8f1fe54..5c2f18b2 100644 --- a/src/modules/punk/args-buildversion.txt +++ b/src/modules/punk/args-buildversion.txt @@ -1,3 +1,3 @@ -0.1.8 +0.1.9 #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 ce4b6842..38963a8a 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -47,6 +47,8 @@ package require Tcl 8.6- package require punk::args +package require punk::ansi +package require textblock #*** !doctools #[item] [package {Tcl 8.6}] #[item] [package {punk::args}] @@ -142,7 +144,6 @@ tcl::namespace::eval punk::args::tclcore { variable PUNKARGS namespace eval argdoc { - package require punk::ansi tcl::namespace::import ::punk::ansi::a+ tcl::namespace::import ::punk::args::tclcore::manpage_tcl # -- --- --- --- --- @@ -154,6 +155,13 @@ tcl::namespace::eval punk::args::tclcore { set B [a+ bold] set N [a+ normal] # -- --- --- --- --- + proc example {str} { + set str [string trimleft $str \n] + set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] + set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"] + #puts $result + return $result + } } @@ -304,80 +312,81 @@ tcl::namespace::eval punk::args::tclcore { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - # library commands loaded via auto_index # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::parray - @cmd -name "Builtin: parray" -help\ - "Prints on standard output the names and values of all the elements in the - array arrayName, or just the names that match pattern (using the matching - rules of string_match) and their values if pattern is given. - ArrayName must be an array accessible to the caller of parray. It may either - be local or global. The result of this command is the empty string. - (loaded via auto_index)" - @values -min 1 -max 2 - arrayName -type string -help\ - "variable name of an array" - pattern -type string -optional 1 -help\ - "Match pattern possibly containing glob characters" - } "@doc -name Manpage: -url [manpage_tcl library]" ] + # + # library commands loaded via auto_index + # # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::parray + @cmd -name "Builtin: parray" -help\ + "Prints on standard output the names and values of all the elements in the + array arrayName, or just the names that match pattern (using the matching + rules of string_match) and their values if pattern is given. + ArrayName must be an array accessible to the caller of parray. It may either + be local or global. The result of this command is the empty string. + (loaded via auto_index)" + @values -min 1 -max 2 + arrayName -type string -help\ + "variable name of an array" + pattern -type string -optional 1 -help\ + "Match pattern possibly containing glob characters" + } "@doc -name Manpage: -url [manpage_tcl library]" ] - lappend PUNKARGS [list { - #test of @form - @id -id ::after - @cmd -name "Builtin: after" -help\ - "Execute a command after a time delay." - - # ---------- shared elements ------------- - @ref -id common_script_help -help\ - "script argument to be concatenated in the same fashion as the concat command" - # ---------- shared elements ------------- - - #@form -form {delay} -synopsis "after ms" - @form -form {delay} - @form -form {schedule_ms} -synopsis "after ms ?script...?" - - #review - #@values -form {*} #note "classify next argument as a value not a leader" - #@values -form {*} - @leaders -form {delay schedule_ms} -min 1 -max 1 - ms -form {*} -type int -help\ - "milliseconds" - - @values -form {delay} -min 0 -max 0 - - @values -form {schedule_ms} -min 1 - script -form {schedule_ms} -multiple 1 -optional 0 ref-help common_script_help - - - @form -form {cancelid} -synopsis "after cancel id" - @leaders -min 1 -max 1 - cancel -choices {cancel} - @values -min 1 -max 1 - id - - - @form -form {cancelscript} -synopsis "after cancel script ?script...?" - @leaders -min 1 - cancel -choices {cancel} - @values -min 1 - script -multiple 1 -optional 0 ref-help common_script_help - - - @form -form {schedule_idle} -synopsis "after idle script ?script...?" - @leaders -min 1 -max 1 - idle -choices {idle} - @values -min 1 - script -multiple 1 -optional 0 ref-help common_script_help + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::foreachLine + @cmd -name "Builtin: foreachLine" -help\ + "This reads in the text file named ${$I}filename${$NI} one line at a time (using system + defaults for reading text files). It writes that line to the variable named + by ${$I}varName${$NI} and then executes ${$I}body${$NI} for that line. The result value of ${$I}body${$NI} is + ignored, but error, return, break and continue may be used within it to + produce an error, return from the calling context, stop the loop, or go to + the next line respectively. The overall result of ${$B}foreachLine${$N} is the empty + string (assuming no errors from I/O or from evaluating the body of the loop); + the file will be closed prior to the procedure returning." + @values -min 3 -max 3 + varName + fileName + body + } "@doc -name Manpage: -url [manpage_tcl library]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::readFile + @cmd -name "Builtin: readFile" -help\ + "Reads in the file named in ${$I}filename${$NI} and returns its contents. The second + argument says how to read in the file, either as ${$B}text${$N} (using the system + defaults for reading text files) or as ${$B}binary${$N} (as uninterpreted bytes). + The default is ${$B}text${$N}. When read as text, this will include any trailing + newline. The file will be closed prior to the procedure returning." + @values -min 1 -max 2 + fileName + #todo punk::args::synopsis - show prefix highlighting + mode -type literalprefix(text)|literalprefix(binary) -optional 1 + } "@doc -name Manpage: -url [manpage_tcl library]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::writeFile + @cmd -name "Builtin: writeFile" -help\ + "Writes the contents to the file named in ${$I}filename${$NI}. The optional second + argument says how to write to the file, either as ${$B}text${$N} (using the system + defaults for writing text files) or as ${$B}binary${$N} (as uninterpreted bytes). + The default is ${$B}text${$N}. If a trailing newline is required, it will need to + be provided in ${$I}contents${$NI}. The result of this command is the empty string; + the file will be closed prior to the procedure returning." + @values -min 2 -max 3 + fileName + mode -type literalprefix(text)|literalprefix(binary) -optional 1 + contents + } "@doc -name Manpage: -url [manpage_tcl library]" ] - @form -form {info} -synopsis "after info ?id?" - @leaders -min 1 -max 1 - info -choices {info} - @values -min 0 -max 1 - id -optional 1 + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + # (end of auto_index commands) + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - } "@doc -name Manpage: -url [manpage_tcl after]" ] namespace eval argdoc { punk::args::define { @@ -700,7 +709,7 @@ tcl::namespace::eval punk::args::tclcore { @form -form {set} @values -min 3 -max -1 channel - "optionName value" -type {string any} -multiple 1 -optional 0 + "optionName value" -type {string any} -typesynopsis {optionName value} -multiple 1 -optional 0 } "@doc -name Manpage: -url [manpage_tcl chan]" ] @@ -806,7 +815,7 @@ tcl::namespace::eval punk::args::tclcore { as arguments (keys and values alternating, with each key being followed by its associated value)" @values -min 2 -max -1 - "key value" -type {string string} -optional 1 -multiple 1 + "key value" -type {string string} -typesynopsis {key value} -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl dict]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @@ -845,14 +854,7 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl dict]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - proc example {str} { - set str [string trimleft $str \n] - set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block -- $str]] - set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"] - #puts $result - return $result - } - lappend PUNKARGS [list { + punk::args::define { @id -id ::tcl::dict::get @cmd -name "Builtin: tcl::dict::get" -help\ "Given a dictionary value (first argument) and a key (second argument), this @@ -877,8 +879,158 @@ tcl::namespace::eval punk::args::tclcore { @values -min 1 -max -1 dictionaryValue -type dict key -type string -multiple 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::tcl::dict::getdef + @cmd -name "Builtin: tcl::dict::getdef" -help\ + "This behaves the same as ${$B}dict get${$N} (with at least one ${$I}key${$NI} argument), + returning the value that the key path maps to in the dictionary + ${$I}dictionaryValue${$NI}, except that instead of producing an error because the + ${$I}key${$NI} (or one of the ${$I}key${$NI}s on the key path) is absent, it returns the + ${$I}default${$NI} argument instead. + Note that there must always be at least one ${$I}key${$NI} provided, and that ${$B}dict getdef${$N} and + ${$B}dict getwithdefault${$N} are aliases for each other." + @values -min 1 -max -1 + dictionaryValue -type dict + key -type string -multiple 1 -optional 0 + default -type any -optional 0 + } "@doc -name Manpage: -url [manpage_tcl dict]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #use getdef to define getwithdefault + punk::args::define [punk::args::resolved_def -override {@id { + -id ::tcl::dict::getwithdefault + } @cmd { + -name "Builtin: tcl::dict::getwithdefault" + }} ::tcl::dict::getdef] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::incr + @cmd -name "Builtin: tcl::dict::incr" -help\ + "This adds the given ${$I}increment${$NI} value (an integer that defaults to 1 if + not specified) to the value that the given key maps to in the dictionary + value contained in the given variable, writing the resulting dictionary + value back to that variable. Non-existent keys are treated as if they + map to 0. It is an error to increment a value for an existing key if that + value is not an integer. The updated dictionary value is returned. If + ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array + that has a default value set, the default value and will be used as the + value of the dictionary prior to the incrementing operation." + @values -min 2 -max 3 + dictionaryVariable -type string + key -type any + increment -type integer -default 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::info + @cmd -name "Builtin: tcl::dict::info" -help\ + "This returns information (intended for display to people) about the + given dictionary though the format of this data is dependent on the + implementation of the dictionary. For dictionaries that are implemented + by hash tables, it is expected that this will return the string produced + by ${$B}Tcl_HashStats${$N}, similar to ${$B}array statistics${$N}." + @values -min 1 -max 1 + dictionaryValue -type dict + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::keys + @cmd -name "Builtin: tcl::dict::keys" -help\ + "Return a list of all keys in the given dictionary value. If a pattern is + supplied, only those keys that match it (according to the rules of ${$B}string + match${$N}) will be returned. The returned keys will be in the order that they + were inserted into the dictionary." + @values -min 1 -max 2 + dictionaryValue -type dict + globPattern -type string -optional 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::lappend + @cmd -name "Builtin: tcl::dict::lappend" -help\ + "This appends the given items to the list value that the given key maps + to in the dictionary value contained in the given variable, writing the + resulting dictionary value back to that variable. Non-existent keys are + treated as if they map to an empty list, and it is legal for there to be + no items to append to the list. It is an error for the value that the key + maps to to not be representable as a list. The updated dictionary value + is returned. If ${$I}dictionaryVariable${$NI} indicates an element that does not + exist of an array that has a default value set, the default value and + will be used as the value of the dictionary prior to the list-appending + operation." + @values -min 2 -max -1 + dictionaryVariable -type dict + key -type any + value -type any -multiple 1 -optional 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::map + @cmd -name "Builtin: tcl::dict::map" -help\ + "This command applies a transformation to each element of a dictionary, + returning a new dictionary. It takes three arguments: the first is a + two-element list of variable names (for the key and value respectively of + each mapping in the dictionary), the second the dictionary value to + iterate across, and the third a script to be evaluated for each mapping + with the key and value variables set appropriately (in the manner of ${$B}lmap${$N}). + In an iteration where the evaluated script completes normally (${$B}TCL_OK${$N}, as + opposed to an ${$B}error${$N}, etc.) the result of the script is put into an + accumulator dictionary using the key that is the current contents of the + keyVariable variable at that point. The result of the ${$B}dict map${$N} command is + the accumulator dictionary after all keys have been iterated over. + + If the evaluation of the body for any particular step generates a break, + no further pairs from the dictionary will be iterated over and the ${$B}dict + map${$N} command will terminate successfully immediately. If the evaluation of + the body for a particular step generates a continue result, the current + iteration is aborted and the accumulator dictionary is not modified. The + order of iteration is the natural order of the dictionary (typically the + order in which the keys were added to the dictionary; the order is the + same as that used in ${$B}dict for${$N})." + @values -min 3 -max 3 + "{keyVariable valueVariable}" -type list -minsize 2 -maxsize 2 + dictionaryValue -type dict + body -type script + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::merge + @cmd -name "Builtin: tcl::dict::merge" -help\ + "Return a dictionary that contains the contents of each of the + ${$I}dictionaryValue${$NI} arguments. Where two (or more) dictionaries + contain a mapping for the same key, the resulting dictionary maps that + key to the value according to the last dictionary on the command line + containing a mapping for that key." + @values -min 0 -max -1 + dictionaryValue -type dict -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::remove + @cmd -name "Builtin: tcl::dict::remove" -help\ + "Return a new dictionary that is a copy of an old one passed in as first + argument except without mappings for each of the keys listed. It is legal + for there to be no keys to remove, and it also legal for any of the keys + to be removed to not be present in the input dictionary in the first place." + @values -min 1 -max -1 + dictionaryValue -type dict + key -type any -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl dict]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::dict::replace @cmd -name "Builtin: tcl::dict::replace" -help\ @@ -888,8 +1040,86 @@ tcl::namespace::eval punk::args::tclcore { but illegal for this command to be called with a key but no value." @values -min 1 -max -1 dictionaryValue -type dict - "key value" -type {string string} -optional 1 -multiple 1 + "key value" -type {any any} -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::set + @cmd -name "Builtin: tcl::dict::set" -help\ + "This operation takes the name of a variable containing a dictionary value + and places an updated dictionary value in that variable containing a + mapping from the given key to the given value. When multiple keys are + present, this operation creates or updates a chain of nested dictionaries. + The updated dictionary value is returned. If ${$I}dictionaryVariable${$NI} indicates + an element that does not exist of an array that has a default value set, + the default value and will be used as the value of the dictionary prior to + the value insert/update operation." + @values -min 3 -max -1 + dictionaryVariable -type string + key -type string -optional 0 -multiple 1 + value -type any + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::size + @cmd -name "Builtin: tcl::dict::size" -help\ + "Return the number of key/value mappings in the given dictionary value." + @values -min 1 -max 1 + dictionaryValue -type dict + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::unset + @cmd -name "Builtin: tcl::dict::unset" -help\ + "This operation (the companion to ${$B}dict set${$NI}) takes the name of a variable + containing a dictionary value and places an updated dictionary value in + that variable that does not contain a mapping for the given key. Where + multiple keys are present, this describes a path through nested + dictionaries to the mapping to remove. At least one key must be specified, + but the last key on the key-path need not exist. All other components on + the path must exist. The updated dictionary value is returned. If + ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array + that has a default value set, the default value and will be used as the + value of the dictionary prior to the value remove operation." + @values -min 2 -max -1 + dictionaryVariable -type string + key -type string -optional 0 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::update + @cmd -name "Builtin: tcl::dict::update" -help\ + "Execute the Tcl script in ${$I}body${$NI} with the value for each ${$I}key${$NI} (as found by + reading the dictionary value in ${$I}dictionaryVariable${$NI}) mapped to the variable + ${$I}varName${$NI}. There may be multiple ${$I}key/varName${$NI} pairs. If a ${$I}key${$NI} does not have a + mapping, that corresponds to an unset ${$I}varName${$NI}. When ${$I}body${$NI} terminates, any + changes made to the ${$I}varName${$NI}s is reflected back to the dictionary within + ${$I}dictionaryVariable${$NI} (unless ${$I}dictionaryVariable${$NI} itself becomes unreadable, + when all updates are silently discarded), even if the result of ${$I}body${$NI} is an + error or some other kind of exceptional exit. The result of dict update is + (unless some kind of error occurs) the result of the evaluation of ${$I}body${$NI}. + If ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array + that has a default value set, the default value and will be used as the + value of the dictionary prior to the update operation. + + Each ${$I}varName${$NI} is mapped in the scope enclosing the dict update; it is + recommended that this command only be used in a local scope (${$B}proc${$N}edure, + lambda term for ${$B}apply${$N}, or method). Because of this, the variables set by + ${$B}dict update${$N} will continue to exist after the command finishes (unless + explicitly unset). + + Note that the mapping of values to variables does not use traces; changes + to the ${$I}dictionaryVariable${$NI}'s contents only happen when ${$I}body${$NI} terminates." + @values -min 4 -max -1 + dictionaryVariable -type string + "key varName" -type {any any} -typesynopsis {key varName} -optional 0 -multiple 1 + body -type script -typesynopsis body