diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 9c7c728c..b8d172da 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.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/bootsupport/modules/punk/args-0.1.8.tm b/src/bootsupport/modules/punk/args-0.1.8.tm index 9a90e2e4..c17ecc2c 100644 --- a/src/bootsupport/modules/punk/args-0.1.8.tm +++ b/src/bootsupport/modules/punk/args-0.1.8.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...? @@ -428,10 +430,8 @@ tcl::namespace::eval punk::args { 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 + number list indexexpression dict @@ -440,12 +440,19 @@ tcl::namespace::eval punk::args { 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 + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) and more.. (todo - document here) @@ -499,6 +506,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 @@ -635,12 +645,15 @@ tcl::namespace::eval punk::args { LEADER_NAMES [list]\ LEADER_MIN ""\ LEADER_MAX ""\ + LEADER_UNNAMED false\ LEADERSPEC_DEFAULTS $leaderspec_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\ OPT_CHECKS_DEFAULTS {}\ @@ -649,6 +662,7 @@ tcl::namespace::eval punk::args { VAL_NAMES [list]\ VAL_MIN ""\ VAL_MAX ""\ + VAL_UNNAMED false\ VALSPEC_DEFAULTS $valspec_defaults\ VAL_CHECKS_DEFAULTS {}\ FORMDISPLAY [tcl::dict::create]\ @@ -1212,12 +1226,20 @@ 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 { + dict set F $fid OPT_MAX $v + } + -minsize - -maxsize - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - + -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { #review - only apply to certain types? tcl::dict::set tmp_optspec_defaults $k $v } @@ -1253,21 +1275,29 @@ tcl::namespace::eval punk::args { } tcl::dict::set tmp_optspec_defaults -type $v } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - -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::define - 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 -range -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 -prefix\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ @@ -1308,13 +1338,21 @@ tcl::namespace::eval punk::args { } dict set F $fid LEADER_MAX $v } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + -choiceprefix - + -choicerestricted { + if {![string is boolean -strict $v]} { + error "punk::args::define - 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 + } + -minsize - -maxsize - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefixdenylist - -choiceprefixreservelist - -nocase { #review - only apply to certain types? 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::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" } tcl::dict::set tmp_leaderspec_defaults $k $v } @@ -1351,17 +1389,28 @@ tcl::namespace::eval punk::args { } 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::define - 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::define - 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 @@ -1370,10 +1419,12 @@ tcl::namespace::eval punk::args { 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" } @@ -1411,7 +1462,8 @@ tcl::namespace::eval punk::args { #set val_max $v dict set F $fid VAL_MAX $v } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - + -choicelabels - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set tmp_valspec_defaults $k $v } @@ -1458,21 +1510,34 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - + -multiple { + if {![string is boolean -strict $v]} { + error "punk::args::define - 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::define - 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\ + -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 @values line. Known keys: $known @id:$DEF_definition_id" } @@ -1588,58 +1653,87 @@ 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 - } - "" - 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. + #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] + #normalize here so we don't have to test during actual args parsing in main function + switch -- $lc_typespec { + int - integer { + lappend typelist int + } + double - float { + #review - user may wish to preserve 'float' in help display - consider how best to implement + lappend typelist double + } + bool - boolean { + lappend typelist bool + } + char - character { + lappend typelist char + } + dict - dictionary { + lappend typelist dict + } + index - indexexpression { + lappend typelist indexexpression + } + "" - none { + 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 $typelist] > 1} { + #makes no sense to have 'none' in a clause + error "punk::args::define - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" + } + #tcl::dict::set spec_merged -type none + lappend typelist 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::define - invalid -type 'none' 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 { + lappend typelist any + } + ansi - ansistring { + lappend typelist ansistring + } + string - globstring { + lappend typelist $lc_typespec + } + 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" + } + lappend typelist literal + } + default { + if {[string match literal* $lc_typespec]} { + set literal_tail [string range $typespec 7 end] + lappend typelist 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] + lappend typelist $lc_typespec + } } - 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] } } + tcl::dict::set spec_merged -type $typelist } -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -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 @@ -1701,7 +1795,8 @@ tcl::namespace::eval punk::args { } } } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + set known_argopts [list -form -default -type -range -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\ @@ -1726,7 +1821,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 +1839,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] @@ -3136,6 +3234,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 +3296,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 +3317,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 +3330,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 +3340,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 +3411,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 @@ -3538,7 +3641,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 +3737,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 +3925,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 +4010,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 +4022,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,6 +4156,227 @@ tcl::namespace::eval punk::args { #TODO } + + #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] + + #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 ?] + 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 + } + } else { + #break + } + } else { + #break + } + if {!$alloc_ok} { + if {![dict get $ARG_INFO $clausename -optional]} { + break + } + } + } 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 + 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 + } + 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] + 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 + 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] + 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 ?] + 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 { + set match $membername + } + if {$v eq $match} { + if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { + lappend resultlist "" + } else { + lappend resultlist $v + incr alloc_count + } + } else { + if {$clause_member_optional} { + #todo - configurable default for optional clause members? + lappend resultlist "" + } else { + set alloc_ok 0 + break + } + } + } else { + if {$clause_member_optional} { + if {$alloc_count >= [llength $all_remaining]} { + lappend resultlist "" + } else { + lappend resultlist $v + incr alloc_count + } + } else { + lappend resultlist $v + incr alloc_count + } + } + if {$alloc_count > [llength $all_remaining]} { + set alloc_ok 0 + break + } + } + if {$alloc_ok} { + set d [dict create consumed $alloc_count resultlist $resultlist] + } else { + set d [dict create consumed 0 resultlist {}] + } + #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 # @@ -4092,8 +4495,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 { @@ -4121,12 +4534,18 @@ tcl::namespace::eval punk::args { 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) + #(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 set named_leader_args_max 0 foreach ln $LEADER_NAMES { incr named_leader_args_max [llength $ln] } + + #set id [dict get $argspecs id] + #if {$id eq "::if"} { + #puts stderr "::if" + #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" + #} set nameidx 0 if {$LEADER_MAX != 0} { for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { @@ -4148,13 +4567,13 @@ tcl::namespace::eval punk::args { } else { set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string } - if {$r eq "--"} { + if {$OPT_MAX ne "0" && $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)} { + if {$OPT_MAX ne "0" && [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 {$matchopt ne ""} { #flaglike matches a known flag - don't treat as leader @@ -4182,7 +4601,8 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { - set stridelength [llength $leader_posn_name] + #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" + set clauselength [llength $leader_posn_name] if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader @@ -4200,18 +4620,18 @@ tcl::namespace::eval punk::args { # continue # } #} - if {[llength $remaining_rawargs] < $stridelength} { + if {[llength $remaining_rawargs] < $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] - $clauselength < $valmin} { break } - #leadername may be a 'stride' of arbitrary length (e.g {"key val"} or {"key val etc"}) + #leadername may be a 'clause' of arbitrary length (e.g {"key val"} or {"key val etc"}) incr ridx -1 foreach v $leader_posn_name { incr ridx @@ -4225,19 +4645,19 @@ tcl::namespace::eval punk::args { #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} { + if {[llength $remaining_rawargs] < $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] - $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] < $clauselength} { #not enough remaining args to fill *required* leader break } @@ -4311,6 +4731,12 @@ tcl::namespace::eval punk::args { 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,7 +4744,7 @@ tcl::namespace::eval punk::args { #valmin, valmax #puts stderr "remaining_rawargs: $remaining_rawargs" #puts stderr "argstate: $argstate" - if {[lsearch $remaining_rawargs -*] >= 0} { + if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { #at least contains flaglike things.. set maxidx [expr {[llength $remaining_rawargs] -1}] if {$valmax == -1} { @@ -4459,7 +4885,7 @@ tcl::namespace::eval punk::args { } if {$OPT_ANY} { set newval [lindex $remaining_rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any|-arbitrary true - 'adhoc/passthrough' option tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS if {[tcl::dict::get $argstate $a -type] ne "none"} { @@ -4499,7 +4925,7 @@ tcl::namespace::eval punk::args { 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" + 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 $fullopt @@ -4522,8 +4948,13 @@ 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] @@ -4536,7 +4967,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 +4982,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 +4994,96 @@ 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 + #incr nameidx set ldr [lindex $leaders $ldridx] if {$leadername ne ""} { - if {[llength $leadername] == 1} { - set strideval $ldr + set typelist [tcl::dict::get $argstate $leadername -type] + if {[llength $typelist] == 1} { + set clauseval $ldr } else { - set strideval [list] + set clauseval [list] incr ldridx -1 - foreach v $leadername { + foreach t $typelist { 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 + set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername', but requires [llength $leadername] values" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadername] ] -argspecs $argspecs]] $msg } - lappend strideval [lindex $leaders $ldridx] + lappend clauseval [lindex $leaders $ldridx] } } 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 typelist [tcl::dict::get $argstate $leadername_multiple -type] + if {[llength $typelist] == 1} { + set clauseval $ldr } else { - set strideval [list] + set clauseval [list] incr ldridx -1 - foreach v $leadername_multiple { + foreach t $typelist { 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 [llength $leadername_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadername_multiple] ] -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 +5091,147 @@ 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 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] + 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 -1 + incr validx $consumed + 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 $valname] ] -argspecs $argspecs]] $msg + } + + #for {set i 0} {$i < $consumed} {incr i} { + # incr validx + # if {$validx > [llength $values]-1} { + # 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 $valname] ] -argspecs $argspecs]] $msg + # } + # #lappend clauseval [lindex $values $validx] + #} + } 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 +5269,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 +5308,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 @@ -4826,7 +5338,7 @@ tcl::namespace::eval punk::args { tcl::dict::for {argname v} $opts_and_values { if {[string match -* $argname]} { #get full option name such as -fg|-foreground from non-alias name such as -foreground - #if "@opts -any true" - we may have an option that wasn't defined + #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined if {[dict exists $lookup_optset $argname]} { set argname [dict get $lookup_optset $argname] } @@ -4842,7 +5354,7 @@ 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 @@ -4889,18 +5401,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 {$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 +5497,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 +5512,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 +5523,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 +5603,24 @@ 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 {$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} { + set vlist_validate [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 + } } + 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 @@ -5128,7 +5648,9 @@ 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] + set type [lindex $typelist 0] if {[llength $vlist]} { + switch -- $type { literal { foreach e $vlist { @@ -5513,20 +6035,8 @@ 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] } @@ -5680,31 +6190,76 @@ 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 arginfo [dict get $forminfo ARG_INFO $argname] + set typelist [dict get $arginfo -type] + if {[llength $typelist] == 1} { + set tp [lindex $typelist 0] + 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$argname$RST + } + } else { + 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 "" + foreach typespec $typelist 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 { + set c $I$tp$RST + } + if {$member_optional} { + append clause " " "(?$c?)" + } else { + 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 "?$I$argname$RST?..." + set display "?$clause?..." } 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?" - } else { - set display "?$I$argname$RST?" - } + 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 "$I$argname$RST ?$I$argname$RST?..." + set display "$clause ?$clause?..." } 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 - } else { - set display "$I$argname$RST" - } + 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" diff --git a/src/bootsupport/modules/punk/args-0.1.9.tm b/src/bootsupport/modules/punk/args-0.1.9.tm new file mode 100644 index 00000000..e64f2d54 --- /dev/null +++ b/src/bootsupport/modules/punk/args-0.1.9.tm @@ -0,0 +1,7959 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.9 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.9] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %G% \x1b\[32m %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + (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|-arbitrary + %B%@values%N% ?opt val...? + (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...? + (used for commands with multiple forms) + directive-options: -form -synopsis + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + int + integer + number + list + indexexpression + dict + double + float + bool + boolean + char + file + directory + ansistring + globstring + (any of the types accepted by 'string is') + + 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. + + -typesynopsis + Must be same length as value in -type + This provides and override for synopsis display of types. + Any desired italicization must be applied manually to the + value. + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + 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 + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant - only valid if -type is a single item) + -typeranges (list with same number of elements as -type) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + {Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + ${[punk::args::tclcore::argdoc::example { + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\ + "Description of command" + + %G%#The following option defines an option-value pair%R% + %G%#It may have aliases by separating them with a pipe |%R% + -fg|-foreground -default blah -type string -help\ + "In the result dict returned by punk::args::parse + the value used in the opts key will always be the last + entry, in this case -foreground" + %G%#The following option defines a flag style option (solo)%R% + -flag1 -default 0 -type none -help\ + "Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars" + + @values -min 1 -max -1 + %G%#Items that don't begin with * or - are value definitions%R% + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } "@doc -name Manpage: -url [myfunc_manpage_geturl myns::myfunc]"}]} + } + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderdirective_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -ensembleparameter 0\ + ] + set optdirective_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valdirective_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + 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 $optdirective_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VAL_UNNAMED false\ + VALSPEC_DEFAULTS $valdirective_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache [list $optionspecs]] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + + #set opt_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + 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::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. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::resolve @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + 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] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - -arbitrary - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -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 + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + #v is a typelist + #foreach t $v { + # #validate? + #} + tcl::dict::set tmp_optspec_defaults -type $v + } + -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 { + #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 -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::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + 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] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + 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} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + 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 + } + -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 - -choicelabels { + if {[llength $v] %2 != 0} { + 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 + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + #$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 - + -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::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 -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::resolve - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + 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 + } + -max - + -maxvalues { + if {$v < -1} { + 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 - -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::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -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- + } + } + 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 { + 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 { -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\ + -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -unnamed\ + } + error "punk::args::resolve - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + 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 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::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] + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + 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} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + 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} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #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 + } + #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" + } + } + 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 + } + } + } + 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 - + -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 + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #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::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 { + -command - -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + 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 { + if {[string match ref-* $spec]} { + #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::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 "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + 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 -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::resolve - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + 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"} { + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + 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 + } + 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]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + + + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #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] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + #set fullk [tcl::prefix::match -error "" {-return -form -types -antiglobs -override} $k] + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "\"$m\" $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "\"$m\" $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$deflist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set deflist [raw_def $id] + if {$deflist eq ""} { + return + } + return [resolve {*}$deflist] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + variable arg_error_CLR + array set arg_error_CLR {} + set arg_error_CLR(errormsg) [a+ brightred] + set arg_error_CLR(title) "" + set arg_error_CLR(check) [a+ brightgreen] + set arg_error_CLR(solo) [a+ brightcyan] + set arg_error_CLR(choiceprefix) [a+ underline] + set arg_error_CLR(badarg) [a+ brightred] + set arg_error_CLR(goodarg) [a+ green strike] + set arg_error_CLR(goodchoice) [a+ reverse] + set arg_error_CLR(linebase_header) [a+ white] + set arg_error_CLR(cmdname) [a+ brightwhite] + set arg_error_CLR(groupname) [a+ bold] + set arg_error_CLR(ansiborder) [a+ bold] + set arg_error_CLR(ansibase_header) [a+ bold] + set arg_error_CLR(ansibase_body) [a+ white] + variable arg_error_CLR_nocolour + array set arg_error_CLR_nocolour {} + set arg_error_CLR_nocolour(errormsg) [a+ bold] + set arg_error_CLR_nocolour(title) [a+ bold] + set arg_error_CLR_nocolour(check) "" + set arg_error_CLR_nocolour(solo) "" + set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment + set arg_error_CLR_nocolour(goodarg) [a+ strike] + set arg_error_CLR_nocolour(cmdname) [a+ bold] + set arg_error_CLR_nocolour(linebase_header) "" + set arg_error_CLR_nocolour(linebase) "" + set arg_error_CLR_nocolour(ansibase_body) "" + variable arg_error_CLR_info + array set arg_error_CLR_info {} + set arg_error_CLR_info(errormsg) [a+ brightred bold] + set arg_error_CLR_info(title) [a+ brightyellow bold] + set arg_error_CLR_info(check) [a+ brightgreen bold] + set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_info(groupname) [a+ cyan bold] + set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] + set arg_error_CLR_info(ansibase_header) [a+ cyan] + set arg_error_CLR_info(ansibase_body) [a+ white] + variable arg_error_CLR_error + array set arg_error_CLR_error {} + set arg_error_CLR_error(errormsg) [a+ brightred bold] + set arg_error_CLR_error(title) [a+ brightcyan bold] + set arg_error_CLR_error(check) [a+ brightgreen bold] + set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_error(groupname) [a+ cyan bold] + set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] + set arg_error_CLR_error(ansibase_header) [a+ yellow] + set arg_error_CLR_error(ansibase_body) [a+ white] + + + #bas ic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + upvar ::punk::args::arg_error_CLR CLR + + switch -- $scheme { + nocolour { + variable arg_error_CLR_nocolour + array set CLR [array get arg_error_CLR_nocolour + } + info { + variable arg_error_CLR_info + array set CLR [array get arg_error_CLR_info] + } + error { + variable arg_error_CLR_error + array set CLR [array get arg_error_CLR_error] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + #if {"$argdisplay_header$argdisplay_body" eq ""} { + # set is_custom_argdisplay 0 + #} else { + # set is_custom_argdisplay 1 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + # + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + set lookup_optset [dict create] + if {[llength [dict get $form_dict OPT_NAMES]]} { + set all_opts [list] + foreach optset [dict get $form_dict OPT_NAMES] { + #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 { + dict set lookup_optset $o $optset + #goodargs + } + } + set full_goodargs [list] + #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname + #map -realname to full argname + foreach g $goodargs { + if {[string match -* $g] && [dict exists $lookup_optset $g]} { + lappend full_goodargs [dict get $lookup_optset $g] + } else { + lappend full_goodargs $g + } + } + set goodargs $full_goodargs + if {![catch {package require punk::trie}]} { + #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 + + $trie destroy + foreach optset [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $optset] + if {[dict get $arginfo -prefix]} { + set opt_members [split $optset |] + set odisplay [list] + foreach opt $opt_members { + set id [dict get $idents $opt] + #REVIEW + if {$id eq $opt} { + set prefix $opt + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $opt 0 $idlen-1] + set tail [string range $opt $idlen end] + } + lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail + } + #lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + lappend opt_names_display [join $odisplay |] + } else { + lappend opt_names_display $optset + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $optset + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + 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] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + 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 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } 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 + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist] + } else { + set casemsg " (case sensitive)" + set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist] + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + 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 + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + 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} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + 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} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + 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 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + #puts "punk::args::parse --> '$args'" + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + #unhappy path - not enough options + #review - which form of punk::args::parse? + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + 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" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + 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] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + + #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] + + #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 + } + } + + } 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 + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + #set VAL_MIN 0 + foreach v $VAL_NAMES { + 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 { + set valmin $VAL_MIN + } + + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + #set optnames [lsearch -all -inline $argnames -*] + #JJJ + set all_opts [list] + set lookup_optset [dict create] + foreach optset $OPT_NAMES { + #optset e.g {-x|--longopt|--longopt=|--otherlongopt} + set optmembers [split $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 + set rawargs_copy $rawargs + set remaining_rawargs $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + + + #consider for example: LEADER_NAMES {"k v" 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 { + 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 raw [lindex $rawargs $ridx] ;#received raw arg + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $nameidx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > $named_leader_args_max-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string + } + 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 + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + 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 + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #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] $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] + # incr ridx + # continue + # } + #} + 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] - $min_clauselength < $valmin} { + break + } + + #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 { + #clause is required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #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] - $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] < $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 + if {$end_leaders} { + break + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$valmin > 0} { + if {[llength $remaining_rawargs] > $valmin} { + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #review - if is_multiple, keep going if enough remaining_rawargs for values? + break + } + } + + #incr ridx + } ;# 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 + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - remaining_rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + #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 {} + set post_values {} + #valmin, valmax + #puts stderr "remaining_rawargs: $remaining_rawargs" + #puts stderr "argstate: $argstate" + 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] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + 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 "--"} { + 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 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 {$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 $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] + } else { + tcl::dict::lappend opts $api_opt $flagval + } + if {$api_opt ni $multisreceived} { + lappend multisreceived $api_opt + } + } else { + tcl::dict::set opts $api_opt $flagval + } + #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 $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 { + 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" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + } + + 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 { + 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 + } + } + + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $remaining_rawargs + #set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected + set arglist [list] + } + #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 {string trimright [lindex [split $v |] end] =}] + #unaliased_opts is list of 'api_opt' (to handle flag aliases of form -a1|-a2|-api_opt) + # e.g -fg|-foreground + # e.g -x|--fullname= + #Resulting unaliased_opts from list {-fg|-foreground -x|--fullname=} should be {-foreground --fullname} + foreach o $unaliased_opts optset $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $optset]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $optset] + } + } + #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 + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set leadername_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + + #---------------------------------------- + #Establish firm leaders ordering + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + set start_position $positionalidx + set nameidx 0 + #MAINTENANCE - (*nearly*?) same loop logic as for value + for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { + set leadername [lindex $LEADER_NAMES $nameidx] + set ldr [lindex $leaders $ldridx] + if {$leadername ne ""} { + 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 { + #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 + } + } + } + + 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 $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::set leaders_dict $leadername [list $clauseval] + } + set leadername_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $clauseval + set leadername_multiple "" + incr nameidx + } + lappend leadernames_received $leadername + } else { + if {$leadername_multiple ne ""} { + set leadertypelist [tcl::dict::get $argstate $leadername_multiple -type] + if {[llength $leadertypelist] == 1} { + set clauseval $ldr + } else { + set clauseval [list] + incr ldridx -1 + foreach t $leadertypelist { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + 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 clauseval [lindex $leaders $ldridx] + } + } + 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 { + 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}] + } + #----------------------------------------------------- + #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 "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #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 - (*nearly*?) same loop logic as for leaders + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + set val [lindex $values $validx] + if {$valname ne ""} { + 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 { + #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 + } + } + } + #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 $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::set values_dict $valname [list $clauseval] + } + set valname_multiple $valname + } else { + 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 clauseval $val + } else { + set clauseval [list] + incr validx -1 + 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 $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 clauseval [lindex $values $validx] + } + } + 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 { + 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 + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #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 -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 + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] + if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { + set full_missing [dict get $lookup_optset $missing] + set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #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 + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #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 {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|-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] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + 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 $value_group + } else { + set vlist [list $value_group] + } + #JJJJ + if {[llength $typelist] == 1} { + set vlist [list $vlist] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach clause_value $vlist { + lappend vlist_check [punk::ansi::ansistrip $clause_value] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #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 {$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 choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] + if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { + set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] + if {$chosen eq "" || $chosen in $choiceprefixreservelist} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #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] + } 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 + } + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + 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 + } + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #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]} { + 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 + } + } + } + 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 + } + } + } + } + } + } + } + } + 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 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] + } + 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 + } + } + } + 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 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 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 + } + } + if {[dict exists $thisarg_checks -maxsize]} { + set maxsize [dict get $thisarg_checks -maxsize] + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $maxsize} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $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 + } + } + 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 + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + int { + #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + foreach clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $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 + } + } + 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 integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + double { + foreach clauseval $vlist clauseval_check $vlist_check { + set e_check [lindex $clauseval_check $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 + } + } + } + } + } + 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]} { + 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 + } + } + } + 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 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 + } + } + } + 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 + } + } + 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 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} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set NI [punk::ansi::a+ noitalic] + #set RST [punk::ansi::a] + set RST "\x1b\[m" + } else { + set I "" + set NI "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + 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 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] + set clause [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$argname$NI + } + } + } else { + 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$NI + } else { + set c $td + } + } + if {$member_optional} { + append clause " " "(?$c?)" + } else { + append clause " " $c + } + } + set clause [string trimleft $clause] + } + + set ARGD [dict create argname $argname class leader] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + #set display "?$I$argname$NI?..." + 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$NI?" + #} + } + } else { + if {[dict get $arginfo -multiple]} { + #set display "$I$argname$NI ?$I$argname$NI?..." + 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$NI" + #} + } + } + 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 OPT_NAMES] { + 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>" + set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) + foreach tp_member [split $tp |] { + #-type literal not valid for opt - review + if {[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 { + lappend alternates $I<$tp_member>$NI + } + } + #todo - trie prefixes display? + set alternates [punk::args::lib::lunique $alternates] + set tp_display [join $alternates |] + } + + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname $tp_display?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname $tp_display?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname $tp_display ?$argname $tp_display?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname $tp_display" + } + } + } + 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 VAL_NAMES] { + 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] + set clause [dict get $arginfo -typesynopsis] + } else { + #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 { + lappend alternates $I$argname$NI + } + } + #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 { + 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 + } + #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$NI + } else { + lappend alternates $td + } + } + } + set alternates [punk::args::lib::lunique $alternates] + set c [join $alternates |] + if {$member_optional} { + append clause " " "(?$c?)" + } else { + 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$NI?..." + 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$NI?" + #} + } + } else { + if {[dict get $arginfo -multiple]} { + #set display "$I$argname$NI ?$I$argname$NI?..." + 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$NI" + #} + } + } + 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 + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + showdict $SYND + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + 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]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + #JJJ + #REVIEW + #lappend params [subst -nocommands -novariables $expression] + lappend params $expression + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + 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 ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.9 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 2d949ccf..a0a97ee7 100644 --- a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -496,10 +496,10 @@ namespace eval punk::cap::handlers::templates { @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" @cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\ "" - @opts -anyopts 1 + @opts -any true #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here -startdir -default "" - @values -maxvalues -1 + @values -maxvalues -1 -unnamed true }] method get_itemdict_projectlayouts {args} { @@ -552,6 +552,13 @@ namespace eval punk::cap::handlers::templates { } return $layoutdict } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs" + @cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs " -help\ + "" + @opts -arbitrary true + @values -maxvalues -1 -unnamed 1 + }] method get_itemdict_projectlayoutrefs {args} { set config { -templatefolder_subdir "layout_refs"\ diff --git a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index f018486d..e2f44ad3 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -641,7 +641,7 @@ tcl::namespace::eval punk::nav::fs { @id -id ::punk::nav::fs::dirfiles -stripbase -default 1 -type boolean -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" - @values -min 0 -max -1 + @values -min 0 -max -1 -unnamed true } proc dirfiles {args} { set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] @@ -735,7 +735,7 @@ tcl::namespace::eval punk::nav::fs { #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) -with_sizes -default "\uFFFF" -type string -with_times -default "\uFFFF" -type string - @values -min 0 -max -1 -type string + @values -min 0 -max -1 -type string -unnamed true } proc dirfiles_dict {args} { set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict] @@ -998,7 +998,7 @@ tcl::namespace::eval punk::nav::fs { @id -id ::punk::nav::fs::dirfiles_dict_as_lines -stripbase -default 0 -type boolean -formatsizes -default 1 -type boolean - @values -min 1 -max -1 -type dict + @values -min 1 -max -1 -type dict -unnamed true } #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index b8ad757f..0f609b4f 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -2642,6 +2642,7 @@ tcl::namespace::eval punk::ns { set querycommand [dict get $values commandpath] set queryargs [dict get $values subcommand] + #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" #todo - similar to corp? review corp resolution process #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented @@ -2878,15 +2879,19 @@ tcl::namespace::eval punk::ns { set nextqueryargs [list] ;#build a list of prefix-resolved queryargs set queryargs_untested $queryargs foreach q $queryargs { - if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + #todo: fix set subitems [dict get $spec FORMS $fid LEADER_NAMES] if {[llength $subitems]} { set next [lindex $subitems 0] set arginfo [dict get $spec FORMS $fid ARG_INFO $next] set allchoices [list] - set choices [punk::args::system::Dict_getdef $arginfo -choices {}] - set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + #maintenance smell - similar/dup of some punk::args logic - review + #-choiceprefixdenylist ?? + set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] if {[dict exists $choicegroups ""]} { dict lappend choicegroups "" {*}$choices } else { @@ -2895,8 +2900,8 @@ tcl::namespace::eval punk::ns { dict for {groupname clist} $choicegroups { lappend allchoices {*}$clist } - set resolved_q [tcl::prefix::match -error "" $allchoices $q] - if {$resolved_q eq ""} { + set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] + if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { break } lappend nextqueryargs $resolved_q @@ -3600,7 +3605,30 @@ tcl::namespace::eval punk::ns { } #todo - package up as navns - proc corp {path} { + punk::args::define { + @id -id ::punk::ns::corp + @cmd -name punk::ns::corp -help\ + "Show alias or proc information. + 'corp' (being the reverse spelling of proc) + will display the Tcl 'proc name args body' statement + for the proc. + Essentially this is a convenient way to display the + proc body including argument info, instead of + separately calling 'info args ' 'info body ' + etc. + The body may display with an additional + comment inserted to display information such as the + namespace origin. Such a comment begins with #corp#." + @opts + @values -min 1 -max -1 + commandname -help\ + "May be either the fully qualified path for the command, + or a relative name that is resolvable from the current + namespace." + } + proc corp {args} { + set argd [punk::args::parse $args withid ::punk::ns::corp] + set path [dict get $argd values commandname] #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) if {[info exists punk::console::tabwidth]} { diff --git a/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/bootsupport/modules/punk/zip-0.1.1.tm index 4ba74656..96350c0b 100644 --- a/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -191,6 +191,8 @@ tcl::namespace::eval punk::zip { -excludes -default "" -help "list of glob expressions to match against files and exclude" -subpath -default "" -help\ "May contain glob chars for folder elements" + #If we don't include --, the call walk -- .. will return nothing as 'base' will receive the -- + -- -type none -optional 1 @values -min 1 -max -1 base fileglobs -default {*} -multiple 1 @@ -651,7 +653,7 @@ tcl::namespace::eval punk::zip { } array set opts [dict get $argd opts] - + if {$opts(-directory) ne ""} { if {$opts(-base) ne ""} { diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index 2442e257..31995bfe 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -3928,8 +3928,8 @@ tcl::namespace::eval textblock { set cols [tcl::dict::keys $o_columndata] } else { set cols [list] + set allcols [tcl::dict::keys $o_columndata] foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] if {[tcl::string::first .. $colspec] >=0} { set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] if {[llength $parts] != 3} { @@ -5559,8 +5559,8 @@ tcl::namespace::eval textblock { "Join blocks of text line by line but don't add padding on each line to enforce uniform width. Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner " - -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -ansiresets -type any -default auto + -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" blocks -type any -multiple 1 } @@ -8519,7 +8519,25 @@ tcl::namespace::eval textblock { set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] set cache_patternwidth $actual_contentwidth set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] - set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] + + #review - why do we wrap before overtype call if they have same ansibase? + #underlay is just a block of spaces + #set wrapped_underlay $opt_ansibase$underlay$rstbase + #cache_contentpattern is replacement chars + #set wrapped_cache_contentpattern $opt_ansibase$cache_contentpattern + + set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $underlay $cache_contentpattern] + #puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner" + if {$opt_ansibase ne ""} { + if {[punk::ansi::ta::detect $cache_inner]} { + set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner] + } else { + set cache_inner "$opt_ansibase$cache_inner\x1b\[0m" + } + } + + + #after overtype::block - our actual patternwidth may be less set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] @@ -8587,9 +8605,6 @@ tcl::namespace::eval textblock { if {$actual_contentwidth == 0} { set fs [tcl::string::map [list $FSUB " "] $template] } else { - set resultlines [list] - set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] - set contentindex 0 switch -- $opt_textalign { left {set pad right} right {set pad left} @@ -8603,6 +8618,17 @@ tcl::namespace::eval textblock { } #set cwidth [textblock::width $contents] + #JJJ + set contents_has_ansi [punk::ansi::ta::detect $contents] + if {$opt_ansibase ne ""} { + if {$contents_has_ansi} { + set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents] + } else { + set contents "$opt_ansibase$contents\x1b\[0m" + set contents_has_ansi 1 + } + } + set cwidth $actual_contentwidth if {$opt_pad} { set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) @@ -8612,36 +8638,50 @@ tcl::namespace::eval textblock { set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] } #important to supply end of opts -- to textblock::join - particularly here with arbitrary data - set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays + if {$contents_has_ansi} { + set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays + } else { + set contentblock $paddedcontents + } } else { if {$cwidth > $cache_patternwidth} { set contents [overtype::renderspace -width $cache_patternwidth "" $contents] } - set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line + if {$contents_has_ansi} { + set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line + } else { + set contentblock $contents + } } set tlines [split $template \n] #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. #after textblock::join the reset will be a separate code ie should be exactly ESC[0m - set R [a] - set rlen [tcl::string::length $R] set clines [split $contentblock \n] + set fs "" + #set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] + set pattern_offset [expr {$cache_patternwidth -1}] + set contentindex 0 foreach tline $tlines { - if {[tcl::string::first $FSUB $tline] >= 0} { + set subposn [tcl::string::first $FSUB $tline] + if {$subposn >= 0} { set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { - set content_line [tcl::string::range $content_line $rlen end] + #review - different forms of reset e.g \x1b\[m ?? + if {[string range $content_line 0 3] eq "\x1b\[0m"} { + set content_line [tcl::string::range $content_line 4 end] } - #make sure to replay opt_ansibase to the right of the replacement - lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] + append content_line $opt_ansibase + append fs [tcl::string::replace $tline $subposn $subposn+$pattern_offset $content_line] \n incr contentindex } else { - lappend resultlines $tline + append fs $tline \n } } - set fs [::join $resultlines \n] + if {[string index $fs end] eq "\n"} { + set fs [string range $fs 0 end-1] + } } diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index be445500..7fdc7a4f 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -481,6 +481,12 @@ tcl::namespace::eval punk::args { The number of elements in -typeranges must match the number of elements specified in -type. + -typesynopsis + Must be same length as value in -type + This provides and override for synopsis display of types. + Any desired italicization must be applied manually to the + value. + -optional (defaults to true for flags/switches false otherwise) For non flag/switch arguments - all arguments with @@ -3292,6 +3298,7 @@ tcl::namespace::eval punk::args { #todo set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] if {[string length $form_synopsis] > 90} { + # set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] } if {[string match (autodef)* $form_synopsis]} { @@ -6644,9 +6651,12 @@ tcl::namespace::eval punk::args { } if {$has_punkansi} { set I [punk::ansi::a+ italic] - set RST [punk::ansi::a] + set NI [punk::ansi::a+ noitalic] + #set RST [punk::ansi::a] + set RST "\x1b\[m" } else { set I "" + set NI "" set RST "" } @@ -6727,17 +6737,18 @@ tcl::namespace::eval punk::args { 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 + #set arg_display [dict get $arginfo -typesynopsis] + set clause [dict get $arginfo -typesynopsis] } else { - set clause $I$arg_display$RST + #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$argname$NI + } } } else { set n [expr {[llength $typelist]-1}] @@ -6765,9 +6776,9 @@ tcl::namespace::eval punk::args { set c $match } else { if {$td eq ""} { - set c $I$tp$RST + set c $I$tp$NI } else { - set c $I$td$RST + set c $td } } if {$member_optional} { @@ -6779,10 +6790,10 @@ tcl::namespace::eval punk::args { set clause [string trimleft $clause] } - set ARGD [dict create argname $argname class value] + set ARGD [dict create argname $argname class leader] if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$RST?..." + #set display "?$I$argname$NI?..." set display "?$clause?..." } else { set display "?$clause?" @@ -6791,12 +6802,12 @@ tcl::namespace::eval punk::args { #} elseif {[dict get $arginfo -type] eq "literal"} { # set display "?$argname?" #} else { - # set display "?$I$argname$RST?" + # set display "?$I$argname$NI?" #} } } else { if {[dict get $arginfo -multiple]} { - #set display "$I$argname$RST ?$I$argname$RST?..." + #set display "$I$argname$NI ?$I$argname$NI?..." set display "$clause ?$clause?..." } else { set display $clause @@ -6805,7 +6816,7 @@ tcl::namespace::eval punk::args { #} elseif {[dict get $arginfo -type] eq "literal"} { # set display $argname #} else { - # set display "$I$argname$RST" + # set display "$I$argname$NI" #} } } @@ -6822,8 +6833,25 @@ tcl::namespace::eval punk::args { if {[dict exists $arginfo -typesynopsis]} { set tp_display [dict get $arginfo -typesynopsis] } else { - set tp_display "<$tp>" + #set tp_display "<$tp>" + set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) + foreach tp_member [split $tp |] { + #-type literal not valid for opt - review + if {[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 { + lappend alternates $I<$tp_member>$NI + } + } + #todo - trie prefixes display? + set alternates [punk::args::lib::lunique $alternates] + set tp_display [join $alternates |] } + if {[dict get $arginfo -optional]} { if {[dict get $arginfo -multiple]} { if {$tp eq "none"} { @@ -6865,28 +6893,29 @@ tcl::namespace::eval punk::args { if {[llength $typelist] == 1} { set tp [lindex $typelist 0] if {[dict exists $arginfo -typesynopsis]} { - set arg_display [dict get $arginfo -typesynopsis] + #set arg_display [dict get $arginfo -typesynopsis] + set clause [dict get $arginfo -typesynopsis] } else { - 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 { - lappend alternates $I$arg_display$RST + #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 { + lappend alternates $I$argname$NI + } } + #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 |] } - #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 { 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 @@ -6919,9 +6948,9 @@ tcl::namespace::eval punk::args { lappend alternates $match } else { if {$td eq ""} { - lappend alternates $I$tp$RST + lappend alternates $I$tp$NI } else { - lappend alternates $I$td$RST + lappend alternates $td } } } @@ -6939,7 +6968,7 @@ tcl::namespace::eval punk::args { 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 "?$I$argname$NI?..." set display "?$clause?..." } else { set display "?$clause?" @@ -6948,12 +6977,12 @@ tcl::namespace::eval punk::args { #} elseif {[dict get $arginfo -type] eq "literal"} { # set display "?$argname?" #} else { - # set display "?$I$argname$RST?" + # set display "?$I$argname$NI?" #} } } else { if {[dict get $arginfo -multiple]} { - #set display "$I$argname$RST ?$I$argname$RST?..." + #set display "$I$argname$NI ?$I$argname$NI?..." set display "$clause ?$clause?..." } else { set display $clause @@ -6962,7 +6991,7 @@ tcl::namespace::eval punk::args { #} elseif {[dict get $arginfo -type] eq "literal"} { # set display $argname #} else { - # set display "$I$argname$RST" + # set display "$I$argname$NI" #} } } @@ -6980,6 +7009,7 @@ tcl::namespace::eval punk::args { } summary { set summary "" + showdict $SYND dict for {form arglist} $SYND { append summary $id set class_state leader diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index 38963a8a..df821da9 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -479,7 +479,6 @@ tcl::namespace::eval punk::args::tclcore { method } "@doc -name Manpage: -url [manpage_tcl info]" - #todo - make generic - take command and known_groups_dict proc info_subcommands {} { #package require punk::ns #set subdict [punk::ns::ensemble_subcommands -return dict info] @@ -709,7 +708,7 @@ tcl::namespace::eval punk::args::tclcore { @form -form {set} @values -min 3 -max -1 channel - "optionName value" -type {string any} -typesynopsis {optionName value} -multiple 1 -optional 0 + "optionName value" -type {string any} -typesynopsis {${$I}optionName value${$NI}} -multiple 1 -optional 0 } "@doc -name Manpage: -url [manpage_tcl chan]" ] @@ -815,7 +814,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} -typesynopsis {key value} -optional 1 -multiple 1 + "key value" -type {string string} -typesynopsis {${$I}key${$NI} ${$I}value${$NI}} -optional 1 -multiple 1 } "@doc -name Manpage: -url [manpage_tcl dict]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @@ -1116,8 +1115,8 @@ tcl::namespace::eval punk::args::tclcore { 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