From 7e50ef88f0945c5312a62af8d078c1363609a525 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 11 Jun 2025 01:59:08 +1000 Subject: [PATCH] punk::args minor doc fixes, update bootsupport and vfs --- src/bootsupport/modules/punk/args-0.1.8.tm | 6653 +++++++++++++++++ src/modules/punk/args-999999.0a1.0.tm | 32 +- src/modules/punk/args/tzint-999999.0a1.0.tm | 6 +- .../custom/_project/punk.basic/src/make.tcl | 4 - .../bootsupport/modules/punk/args-0.1.8.tm | 6653 +++++++++++++++++ .../_project/punk.project-0.1/src/make.tcl | 4 - .../bootsupport/modules/punk/args-0.1.8.tm | 6653 +++++++++++++++++ .../_project/punk.shell-0.1/src/make.tcl | 4 - .../_vfscommon.vfs/modules/punk/args-0.1.7.tm | 118 +- .../_vfscommon.vfs/modules/punk/args-0.1.8.tm | 6653 +++++++++++++++++ .../modules/punk/args/tclcore-0.1.0.tm | 6 +- .../modules/punk/args/tzint-1.1.1.tm | 309 + .../modules/test/punk/args-0.1.5.tm | Bin 12165 -> 12171 bytes 13 files changed, 27042 insertions(+), 53 deletions(-) create mode 100644 src/bootsupport/modules/punk/args-0.1.8.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/args-0.1.8.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/args/tzint-1.1.1.tm diff --git a/src/bootsupport/modules/punk/args-0.1.8.tm b/src/bootsupport/modules/punk/args-0.1.8.tm new file mode 100644 index 00000000..0147636c --- /dev/null +++ b/src/bootsupport/modules/punk/args-0.1.8.tm @@ -0,0 +1,6653 @@ +# -*- 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.8 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.8] +#[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 %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...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + 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: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -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. + -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) + + + " + -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 + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + #It may have aliases by separating them with a pipe | + -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\" + #The following option defines a flag style option (solo) + -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 + #Items that don't begin with * or - are value definitions + 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 leaderspec_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 optspec_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 valspec_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 ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_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]] + } 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::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # 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::define @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::define - @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 - + -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 { + #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 { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + 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\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + 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::define - @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::define - 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::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' 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 { + 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 + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - 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::define - 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::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + 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 + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - 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::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } 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::define - 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::define - 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 { + #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. + } + } 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" + } + 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] + } + } + } + -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -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 + } + -default { + tcl::dict::set spec_merged -default $specval + if {![dict exists $argdef_values -optional]} { + tcl::dict::set spec_merged -optional 1 + } + } + -optional { + tcl::dict::set spec_merged -optional $specval + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + 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::define 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::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# 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 {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + 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 {$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 { + # 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] { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach o $optmembers { + dict set lookup_optset $o $optset + #goodargs + } + } + set full_goodargs [list] + #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname + #map -realname to full argname + foreach g $goodargs { + if {[string match -* $g] && [dict exists $lookup_optset $g]} { + lappend full_goodargs [dict get $lookup_optset $g] + } else { + lappend full_goodargs $g + } + } + set goodargs $full_goodargs + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}$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 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 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 {}] + 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] + } + 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_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + 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_test] + 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 -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + 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 + } + } + } + } ;#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]} { + 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" + + } + 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} { + 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" + 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" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + 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 + } + + #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 + #[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 exists $ARG_INFO $v -optional] && ![dict get $ARG_INFO $v -optional]} { + incr valmin + } + } + } 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 { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach opt $optmembers { + dict set lookup_optset $opt $optset + } + } + set ridx 0 + set rawargs_copy $rawargs + set remaining_rawargs $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + #consider for example: LEADER_NAMES {"k v" "a b c" x} + #(i.e strides of 2 3 and 1) + #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 + set named_leader_args_max 0 + foreach ln $LEADER_NAMES { + incr named_leader_args_max [llength $ln] + } + set nameidx 0 + if {$LEADER_MAX != 0} { + for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { + set r [lindex $rawargs $ridx] + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {[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 {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $all_opts $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + if {$leader_posn_name ne ""} { + #false alarm + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + #incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + set stridelength [llength $leader_posn_name] + 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] [lindex $remaining_rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop remaining_rawargs 0] + # incr ridx + # continue + # } + #} + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + #check if enough remaining_rawargs to fill any required values + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + + #leadername may be a 'stride' of arbitrary length (e.g {"key val"} or {"key val etc"}) + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values + #we still need to check if enough values for the leader itself + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill *required* leader + break + } + + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + 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] -1 >= $valmin} { + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop 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 + } + + 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 +#JJJ + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "remaining_rawargs: $remaining_rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $remaining_rawargs -*] >= 0} { + #at least contains flaglike things.. + 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 a [lindex $remaining_rawargs $i] + set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $remaining_rawargs 0 $i] + set post_values [lrange $remaining_rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #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 + } else { + set opt [tcl::prefix match -error "" [list {*}$all_opts --] $a] + if {$opt eq "--"} {set opt ""} + if {[dict exists $lookup_optset $opt]} { + set fullopt [dict get $lookup_optset $opt] + } else { + set fullopt "" + } + if {$fullopt ne ""} { + #e.g when fullopt eq -fg|-foreground + #-fg is an alias , -foreground is the 'api' value for the result dict + #$fullopt remains as the key in the spec + set optmembers [split $fullopt |] + set api_opt [lindex $optmembers end] + + if {![tcl::dict::get $argstate $fullopt -prefix] && $a ni $optmembers} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $all_opts" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $remaining_rawargs 0 $i-1] + #set post_values [lrange $remaining_rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #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) + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + + set flagval [lindex $remaining_rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$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 $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$api_opt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $api_opt 1 + } else { + tcl::dict::lappend opts $api_opt 1 + } + if {$api_opt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 { + #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 with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + if {$OPT_ANY} { + set newval [lindex $remaining_rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $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 $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + 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] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + #--------------------------------------- + set ordered_opts [dict create] + set unaliased_opts [lmap v $OPT_NAMES {lindex [split $v |] end}] + #unaliased_opts is list of 'api_opt' (handle aliases of form -a1|-a2|-api_opt e.g -fg|-foreground) + 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 '-any true' opts after the defined opts + 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] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + 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 - same loop logic as for values + for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { + set leadername [lindex $LEADER_NAMES $nameidx] + incr nameidx + set ldr [lindex $leaders $ldridx] + if {$leadername ne ""} { + if {[llength $leadername] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername', but requires [llength $leadername] values" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + #current stored ldr equals defined default - don't include default in the list we build up + tcl::dict::set leaders_dict $leadername [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $strideval + } + set leadername_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $strideval + } + lappend leadernames_received $leadername + } else { + if {$leadername_multiple ne ""} { + if {[llength $leadername_multiple] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername_multiple { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername_multiple', but requires [llength $leadername_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + tcl::dict::lappend leaders_dict $leadername_multiple $strideval + #name already seen - but must add to leadernames_received anyway (as with opts and values) + lappend leadernames_received $leadername_multiple + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $ldridx + 1}] + } + + #test args parse_withdef_leader_stride - todo + #change to for loop + #foreach leadername $LEADER_NAMES ldr $leaders { + # if {$ldridx+1 > $num_leaders} { + # break + # } + # if {$leadername ne ""} { + # if {[tcl::dict::get $argstate $leadername -multiple]} { + # if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + # tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + # } else { + # tcl::dict::lappend leaders_dict $leadername $ldr + # } + # set leadername_multiple $leadername + # } else { + # tcl::dict::set leaders_dict $leadername $ldr + # } + # lappend leadernames_received $leadername + # } else { + # if {$leadername_multiple ne ""} { + # tcl::dict::lappend leaders_dict $leadername_multiple $ldr + # lappend leadernames_received $leadername_multiple ;#deliberately allow dups! (as with opts and values) + # } else { + # tcl::dict::set leaders_dict $positionalidx $ldr + # tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + # tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + # lappend leadernames_received $positionalidx + # } + # } + # incr ldridx + # incr positionalidx + #} + + + set validx 0 + set valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## 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] { + 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 + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } 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 + } + lappend strideval [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 + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + 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 + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #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 + } + } + set positionalidx [expr {$start_position + $validx + 1}] + } + #------------------------------------------ + + 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 -anyopts 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 + #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 + } + + + #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 {argname v} $opts_and_values { + if {[string match -* $argname]} { + #get full option name such as -fg|-foreground from non-alias name such as -foreground + #if "@opts -any true" - we may have an option that wasn't defined + if {[dict exists $lookup_optset $argname]} { + set argname [dict get $lookup_optset $argname] + } + } + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + 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 type [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] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + 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 e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } 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 {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + 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 { + #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 "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $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 "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + 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 + } + + 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 + } + + #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 e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #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]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -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 e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + 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 e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + 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] + } + } + } + } + } + + #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] + } + + + 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 RST [punk::ansi::a] + } else { + set I "" + 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 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 get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + 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 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?..." + } 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?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } 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" + } + } + } + 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 "" + 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 { + lappend params [subst -nocommands -novariables $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 + } + + + #*** !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.8 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 4a639d0a..9e79bf7b 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -554,7 +554,11 @@ tcl::namespace::eval punk::args { \"Description of command\" #The following option defines an option-value pair - -option1 -default blah -type string + #It may have aliases by separating them with a pipe | + -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\" #The following option defines a flag style option (solo) -flag1 -default 0 -type none -help\\ \"Info about flag1 @@ -4097,7 +4101,17 @@ tcl::namespace::eval punk::args { set pre_values {} set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] + #set optnames [lsearch -all -inline $argnames -*] + #JJJ + set all_opts [list] + set lookup_optset [dict create] + foreach optset $OPT_NAMES { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach opt $optmembers { + dict set lookup_optset $opt $optset + } + } set ridx 0 set rawargs_copy $rawargs set remaining_rawargs $rawargs @@ -4139,7 +4153,7 @@ tcl::namespace::eval punk::args { #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] + set matchopt [::tcl::prefix::match -error {} $all_opts $r] if {$matchopt ne ""} { #flaglike matches a known flag - don't treat as leader break @@ -4273,7 +4287,6 @@ tcl::namespace::eval punk::args { set argstate $ARG_INFO ;#argstate may have entries added set arg_checks $ARG_CHECKS - #JJJJ if {$LEADER_MIN eq ""} { set leadermin 0 } else { @@ -4295,16 +4308,7 @@ tcl::namespace::eval punk::args { #assert - remaining_rawargs has been reduced by leading positionals set opts [dict create] ;#don't set to OPT_DEFAULTS here - set all_opts [list] - set lookup_optset [dict create] - foreach optset $OPT_NAMES { - set optmembers [split $optset |] - lappend all_opts {*}$optmembers - foreach opt $optmembers { - dict set lookup_optset $opt $optset - } - } - +#JJJ set leaders [list] set arglist {} diff --git a/src/modules/punk/args/tzint-999999.0a1.0.tm b/src/modules/punk/args/tzint-999999.0a1.0.tm index 83a71549..17844ffb 100644 --- a/src/modules/punk/args/tzint-999999.0a1.0.tm +++ b/src/modules/punk/args/tzint-999999.0a1.0.tm @@ -114,8 +114,10 @@ tcl::namespace::eval punk::args::tzint { @dynamic @id -id "::tzint::Encode svg" @cmd -name "native tzint::Encode svg" - @leaders -min 0 -max 2 - "varName data" -type {string string} -optional 1 + @leaders -min 2 -max 2 + #review - error msg for Encode without args is "Encode command ?name|varName data? ?-option value ...? + #This implies "varName data" is optional - but in practice it seems not to be (?) + "varName data" -type {string string} -optional 0 @opts -symbology -type string -choicerestricted 0 -choices {${[::punk::args::tzint::argdoc::get_symbologies]}} -height -type integer -help\ diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index b73cbac8..9809dc62 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -2044,10 +2044,6 @@ if {[file exists $mapfile]} { } # -- --- --- --- --- --- --- --- --- --- puts "-- runtime_vfs_map --" -set ver [package require punk::args] -puts "punk::args ver: $ver" -set ifneeded [package ifneeded punk::args $ver] -puts "punk::args ifneeded: $ifneeded" punk::lib::pdict runtime_vfs_map puts "---------------------" puts "-- vfs_runtime_map--" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm new file mode 100644 index 00000000..0147636c --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm @@ -0,0 +1,6653 @@ +# -*- 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.8 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.8] +#[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 %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...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + 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: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -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. + -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) + + + " + -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 + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + #It may have aliases by separating them with a pipe | + -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\" + #The following option defines a flag style option (solo) + -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 + #Items that don't begin with * or - are value definitions + 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 leaderspec_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 optspec_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 valspec_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 ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_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]] + } 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::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # 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::define @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::define - @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 - + -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 { + #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 { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + 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\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + 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::define - @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::define - 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::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' 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 { + 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 + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - 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::define - 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::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + 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 + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - 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::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } 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::define - 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::define - 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 { + #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. + } + } 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" + } + 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] + } + } + } + -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -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 + } + -default { + tcl::dict::set spec_merged -default $specval + if {![dict exists $argdef_values -optional]} { + tcl::dict::set spec_merged -optional 1 + } + } + -optional { + tcl::dict::set spec_merged -optional $specval + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + 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::define 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::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# 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 {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + 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 {$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 { + # 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] { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach o $optmembers { + dict set lookup_optset $o $optset + #goodargs + } + } + set full_goodargs [list] + #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname + #map -realname to full argname + foreach g $goodargs { + if {[string match -* $g] && [dict exists $lookup_optset $g]} { + lappend full_goodargs [dict get $lookup_optset $g] + } else { + lappend full_goodargs $g + } + } + set goodargs $full_goodargs + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}$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 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 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 {}] + 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] + } + 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_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + 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_test] + 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 -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + 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 + } + } + } + } ;#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]} { + 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" + + } + 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} { + 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" + 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" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + 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 + } + + #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 + #[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 exists $ARG_INFO $v -optional] && ![dict get $ARG_INFO $v -optional]} { + incr valmin + } + } + } 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 { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach opt $optmembers { + dict set lookup_optset $opt $optset + } + } + set ridx 0 + set rawargs_copy $rawargs + set remaining_rawargs $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + #consider for example: LEADER_NAMES {"k v" "a b c" x} + #(i.e strides of 2 3 and 1) + #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 + set named_leader_args_max 0 + foreach ln $LEADER_NAMES { + incr named_leader_args_max [llength $ln] + } + set nameidx 0 + if {$LEADER_MAX != 0} { + for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { + set r [lindex $rawargs $ridx] + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {[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 {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $all_opts $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + if {$leader_posn_name ne ""} { + #false alarm + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + #incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + set stridelength [llength $leader_posn_name] + 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] [lindex $remaining_rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop remaining_rawargs 0] + # incr ridx + # continue + # } + #} + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + #check if enough remaining_rawargs to fill any required values + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + + #leadername may be a 'stride' of arbitrary length (e.g {"key val"} or {"key val etc"}) + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values + #we still need to check if enough values for the leader itself + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill *required* leader + break + } + + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + 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] -1 >= $valmin} { + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop 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 + } + + 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 +#JJJ + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "remaining_rawargs: $remaining_rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $remaining_rawargs -*] >= 0} { + #at least contains flaglike things.. + 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 a [lindex $remaining_rawargs $i] + set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $remaining_rawargs 0 $i] + set post_values [lrange $remaining_rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #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 + } else { + set opt [tcl::prefix match -error "" [list {*}$all_opts --] $a] + if {$opt eq "--"} {set opt ""} + if {[dict exists $lookup_optset $opt]} { + set fullopt [dict get $lookup_optset $opt] + } else { + set fullopt "" + } + if {$fullopt ne ""} { + #e.g when fullopt eq -fg|-foreground + #-fg is an alias , -foreground is the 'api' value for the result dict + #$fullopt remains as the key in the spec + set optmembers [split $fullopt |] + set api_opt [lindex $optmembers end] + + if {![tcl::dict::get $argstate $fullopt -prefix] && $a ni $optmembers} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $all_opts" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $remaining_rawargs 0 $i-1] + #set post_values [lrange $remaining_rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #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) + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + + set flagval [lindex $remaining_rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$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 $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$api_opt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $api_opt 1 + } else { + tcl::dict::lappend opts $api_opt 1 + } + if {$api_opt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 { + #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 with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + if {$OPT_ANY} { + set newval [lindex $remaining_rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $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 $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + 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] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + #--------------------------------------- + set ordered_opts [dict create] + set unaliased_opts [lmap v $OPT_NAMES {lindex [split $v |] end}] + #unaliased_opts is list of 'api_opt' (handle aliases of form -a1|-a2|-api_opt e.g -fg|-foreground) + 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 '-any true' opts after the defined opts + 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] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + 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 - same loop logic as for values + for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { + set leadername [lindex $LEADER_NAMES $nameidx] + incr nameidx + set ldr [lindex $leaders $ldridx] + if {$leadername ne ""} { + if {[llength $leadername] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername', but requires [llength $leadername] values" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + #current stored ldr equals defined default - don't include default in the list we build up + tcl::dict::set leaders_dict $leadername [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $strideval + } + set leadername_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $strideval + } + lappend leadernames_received $leadername + } else { + if {$leadername_multiple ne ""} { + if {[llength $leadername_multiple] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername_multiple { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername_multiple', but requires [llength $leadername_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + tcl::dict::lappend leaders_dict $leadername_multiple $strideval + #name already seen - but must add to leadernames_received anyway (as with opts and values) + lappend leadernames_received $leadername_multiple + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $ldridx + 1}] + } + + #test args parse_withdef_leader_stride - todo + #change to for loop + #foreach leadername $LEADER_NAMES ldr $leaders { + # if {$ldridx+1 > $num_leaders} { + # break + # } + # if {$leadername ne ""} { + # if {[tcl::dict::get $argstate $leadername -multiple]} { + # if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + # tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + # } else { + # tcl::dict::lappend leaders_dict $leadername $ldr + # } + # set leadername_multiple $leadername + # } else { + # tcl::dict::set leaders_dict $leadername $ldr + # } + # lappend leadernames_received $leadername + # } else { + # if {$leadername_multiple ne ""} { + # tcl::dict::lappend leaders_dict $leadername_multiple $ldr + # lappend leadernames_received $leadername_multiple ;#deliberately allow dups! (as with opts and values) + # } else { + # tcl::dict::set leaders_dict $positionalidx $ldr + # tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + # tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + # lappend leadernames_received $positionalidx + # } + # } + # incr ldridx + # incr positionalidx + #} + + + set validx 0 + set valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## 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] { + 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 + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } 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 + } + lappend strideval [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 + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + 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 + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #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 + } + } + set positionalidx [expr {$start_position + $validx + 1}] + } + #------------------------------------------ + + 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 -anyopts 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 + #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 + } + + + #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 {argname v} $opts_and_values { + if {[string match -* $argname]} { + #get full option name such as -fg|-foreground from non-alias name such as -foreground + #if "@opts -any true" - we may have an option that wasn't defined + if {[dict exists $lookup_optset $argname]} { + set argname [dict get $lookup_optset $argname] + } + } + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + 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 type [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] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + 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 e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } 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 {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + 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 { + #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 "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $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 "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + 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 + } + + 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 + } + + #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 e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #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]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -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 e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + 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 e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + 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] + } + } + } + } + } + + #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] + } + + + 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 RST [punk::ansi::a] + } else { + set I "" + 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 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 get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + 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 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?..." + } 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?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } 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" + } + } + } + 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 "" + 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 { + lappend params [subst -nocommands -novariables $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 + } + + + #*** !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.8 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index b73cbac8..9809dc62 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -2044,10 +2044,6 @@ if {[file exists $mapfile]} { } # -- --- --- --- --- --- --- --- --- --- puts "-- runtime_vfs_map --" -set ver [package require punk::args] -puts "punk::args ver: $ver" -set ifneeded [package ifneeded punk::args $ver] -puts "punk::args ifneeded: $ifneeded" punk::lib::pdict runtime_vfs_map puts "---------------------" puts "-- vfs_runtime_map--" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm new file mode 100644 index 00000000..0147636c --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm @@ -0,0 +1,6653 @@ +# -*- 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.8 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.8] +#[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 %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...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + 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: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -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. + -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) + + + " + -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 + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + #It may have aliases by separating them with a pipe | + -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\" + #The following option defines a flag style option (solo) + -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 + #Items that don't begin with * or - are value definitions + 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 leaderspec_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 optspec_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 valspec_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 ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_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]] + } 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::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # 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::define @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::define - @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 - + -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 { + #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 { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + 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\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + 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::define - @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::define - 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::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' 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 { + 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 + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - 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::define - 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::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + 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 + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - 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::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } 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::define - 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::define - 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 { + #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. + } + } 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" + } + 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] + } + } + } + -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -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 + } + -default { + tcl::dict::set spec_merged -default $specval + if {![dict exists $argdef_values -optional]} { + tcl::dict::set spec_merged -optional 1 + } + } + -optional { + tcl::dict::set spec_merged -optional $specval + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + 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::define 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::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# 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 {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + 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 {$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 { + # 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] { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach o $optmembers { + dict set lookup_optset $o $optset + #goodargs + } + } + set full_goodargs [list] + #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname + #map -realname to full argname + foreach g $goodargs { + if {[string match -* $g] && [dict exists $lookup_optset $g]} { + lappend full_goodargs [dict get $lookup_optset $g] + } else { + lappend full_goodargs $g + } + } + set goodargs $full_goodargs + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}$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 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 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 {}] + 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] + } + 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_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + 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_test] + 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 -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + 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 + } + } + } + } ;#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]} { + 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" + + } + 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} { + 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" + 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" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + 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 + } + + #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 + #[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 exists $ARG_INFO $v -optional] && ![dict get $ARG_INFO $v -optional]} { + incr valmin + } + } + } 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 { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach opt $optmembers { + dict set lookup_optset $opt $optset + } + } + set ridx 0 + set rawargs_copy $rawargs + set remaining_rawargs $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + #consider for example: LEADER_NAMES {"k v" "a b c" x} + #(i.e strides of 2 3 and 1) + #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 + set named_leader_args_max 0 + foreach ln $LEADER_NAMES { + incr named_leader_args_max [llength $ln] + } + set nameidx 0 + if {$LEADER_MAX != 0} { + for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { + set r [lindex $rawargs $ridx] + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {[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 {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $all_opts $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + if {$leader_posn_name ne ""} { + #false alarm + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + #incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + set stridelength [llength $leader_posn_name] + 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] [lindex $remaining_rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop remaining_rawargs 0] + # incr ridx + # continue + # } + #} + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + #check if enough remaining_rawargs to fill any required values + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + + #leadername may be a 'stride' of arbitrary length (e.g {"key val"} or {"key val etc"}) + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values + #we still need to check if enough values for the leader itself + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill *required* leader + break + } + + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + 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] -1 >= $valmin} { + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop 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 + } + + 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 +#JJJ + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "remaining_rawargs: $remaining_rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $remaining_rawargs -*] >= 0} { + #at least contains flaglike things.. + 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 a [lindex $remaining_rawargs $i] + set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $remaining_rawargs 0 $i] + set post_values [lrange $remaining_rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #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 + } else { + set opt [tcl::prefix match -error "" [list {*}$all_opts --] $a] + if {$opt eq "--"} {set opt ""} + if {[dict exists $lookup_optset $opt]} { + set fullopt [dict get $lookup_optset $opt] + } else { + set fullopt "" + } + if {$fullopt ne ""} { + #e.g when fullopt eq -fg|-foreground + #-fg is an alias , -foreground is the 'api' value for the result dict + #$fullopt remains as the key in the spec + set optmembers [split $fullopt |] + set api_opt [lindex $optmembers end] + + if {![tcl::dict::get $argstate $fullopt -prefix] && $a ni $optmembers} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $all_opts" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $remaining_rawargs 0 $i-1] + #set post_values [lrange $remaining_rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #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) + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + + set flagval [lindex $remaining_rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$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 $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$api_opt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $api_opt 1 + } else { + tcl::dict::lappend opts $api_opt 1 + } + if {$api_opt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 { + #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 with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + if {$OPT_ANY} { + set newval [lindex $remaining_rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $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 $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + 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] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + #--------------------------------------- + set ordered_opts [dict create] + set unaliased_opts [lmap v $OPT_NAMES {lindex [split $v |] end}] + #unaliased_opts is list of 'api_opt' (handle aliases of form -a1|-a2|-api_opt e.g -fg|-foreground) + 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 '-any true' opts after the defined opts + 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] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + 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 - same loop logic as for values + for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { + set leadername [lindex $LEADER_NAMES $nameidx] + incr nameidx + set ldr [lindex $leaders $ldridx] + if {$leadername ne ""} { + if {[llength $leadername] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername', but requires [llength $leadername] values" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + #current stored ldr equals defined default - don't include default in the list we build up + tcl::dict::set leaders_dict $leadername [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $strideval + } + set leadername_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $strideval + } + lappend leadernames_received $leadername + } else { + if {$leadername_multiple ne ""} { + if {[llength $leadername_multiple] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername_multiple { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername_multiple', but requires [llength $leadername_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + tcl::dict::lappend leaders_dict $leadername_multiple $strideval + #name already seen - but must add to leadernames_received anyway (as with opts and values) + lappend leadernames_received $leadername_multiple + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $ldridx + 1}] + } + + #test args parse_withdef_leader_stride - todo + #change to for loop + #foreach leadername $LEADER_NAMES ldr $leaders { + # if {$ldridx+1 > $num_leaders} { + # break + # } + # if {$leadername ne ""} { + # if {[tcl::dict::get $argstate $leadername -multiple]} { + # if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + # tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + # } else { + # tcl::dict::lappend leaders_dict $leadername $ldr + # } + # set leadername_multiple $leadername + # } else { + # tcl::dict::set leaders_dict $leadername $ldr + # } + # lappend leadernames_received $leadername + # } else { + # if {$leadername_multiple ne ""} { + # tcl::dict::lappend leaders_dict $leadername_multiple $ldr + # lappend leadernames_received $leadername_multiple ;#deliberately allow dups! (as with opts and values) + # } else { + # tcl::dict::set leaders_dict $positionalidx $ldr + # tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + # tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + # lappend leadernames_received $positionalidx + # } + # } + # incr ldridx + # incr positionalidx + #} + + + set validx 0 + set valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## 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] { + 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 + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } 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 + } + lappend strideval [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 + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + 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 + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #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 + } + } + set positionalidx [expr {$start_position + $validx + 1}] + } + #------------------------------------------ + + 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 -anyopts 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 + #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 + } + + + #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 {argname v} $opts_and_values { + if {[string match -* $argname]} { + #get full option name such as -fg|-foreground from non-alias name such as -foreground + #if "@opts -any true" - we may have an option that wasn't defined + if {[dict exists $lookup_optset $argname]} { + set argname [dict get $lookup_optset $argname] + } + } + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + 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 type [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] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + 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 e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } 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 {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + 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 { + #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 "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $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 "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + 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 + } + + 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 + } + + #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 e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #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]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -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 e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + 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 e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + 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] + } + } + } + } + } + + #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] + } + + + 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 RST [punk::ansi::a] + } else { + set I "" + 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 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 get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + 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 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?..." + } 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?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } 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" + } + } + } + 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 "" + 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 { + lappend params [subst -nocommands -novariables $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 + } + + + #*** !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.8 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index b73cbac8..9809dc62 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -2044,10 +2044,6 @@ if {[file exists $mapfile]} { } # -- --- --- --- --- --- --- --- --- --- puts "-- runtime_vfs_map --" -set ver [package require punk::args] -puts "punk::args ver: $ver" -set ifneeded [package ifneeded punk::args $ver] -puts "punk::args ifneeded: $ifneeded" punk::lib::pdict runtime_vfs_map puts "---------------------" puts "-- vfs_runtime_map--" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.7.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.7.tm index b04f4966..1fbd03bb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.7.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.7.tm @@ -4096,7 +4096,9 @@ tcl::namespace::eval punk::args { if {$leader_posn_name ne ""} { #there is a named leading positional for this position #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] + foreach v $leader_posn_name { + lappend pre_values [lpop rawargs 0] + } dict incr leader_posn_names_assigned $leader_posn_name incr ridx continue @@ -4107,6 +4109,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { + set stridelength [llength $leader_posn_name] if {$leader_posn_name ni $LEADER_REQUIRED} { #optional leader @@ -4126,22 +4129,27 @@ tcl::namespace::eval punk::args { #} #check if enough rawargs to fill any required values - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { + if {$VAL_MIN > 0 && [llength $rawargs] - $stridelength <= $VAL_MIN || [llength $rawargs] - $stridelength <= [llength $VAL_REQUIRED]} { break } else { - lappend pre_values [lpop rawargs 0] + #leadername may be a 'stride' of arbitrary length (e.g {"key val"} or {"key val etc"}) + foreach v {$leader_posn_name} { + lappend pre_values [lpop rawargs 0] + } dict incr leader_posn_names_assigned $leader_posn_name } } else { #required if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { + if {$VAL_MIN > 0 && [llength $rawargs] - $stridelength <= $VAL_MIN || [llength $rawargs] - $stridelength <= [llength $VAL_REQUIRED]} { break } } #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] + foreach v {$leader_posn_name} { + lappend pre_values [lpop rawargs 0] + } dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -4425,8 +4433,7 @@ tcl::namespace::eval punk::args { set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" + set leadername_multiple "" set leadernames_received [list] set num_leaders [llength $leaders] @@ -4439,37 +4446,103 @@ tcl::namespace::eval punk::args { set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] #---------------------------------------- - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } + set start_position $positionalidx + set nameidx 0 + #MAINTENANCE - same loop logic as for values + for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { + set leadername [lindex $LEADER_NAMES $nameidx] + incr nameidx + set ldr [lindex $leaders $ldridx] if {$leadername ne ""} { + if {[llength $leadername] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values for '$leadername', but requires [llength $leadername] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + if {[tcl::dict::get $argstate $leadername -multiple]} { if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + #current stored ldr equals defined default - don't include default in the list we build up + tcl::dict::set leaders_dict $leadername [list $strideval] ;#important to treat first element as a list } else { - tcl::dict::lappend leaders_dict $leadername $ldr + tcl::dict::lappend leaders_dict $leadername $strideval } - set in_multiple $leadername + set leadername_multiple $leadername } else { - tcl::dict::set leaders_dict $leadername $ldr + tcl::dict::set leaders_dict $leadername $strideval } lappend leadernames_received $leadername } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + if {$leadername_multiple ne ""} { + if {[llength $leadername_multiple] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername_multiple { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values for '$leadername_multiple', but requires [llength $leadername_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + tcl::dict::lappend leaders_dict $leadername_multiple $strideval + #name already seen - but must add to leadernames_received anyway (as with opts and values) + lappend leadernames_received $leadername_multiple } else { tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } } - incr ldridx - incr positionalidx + set positionalidx [expr {$start_position + $ldridx + 1}] } + #test args parse_withdef_leader_stride - todo + #change to for loop + #foreach leadername $LEADER_NAMES ldr $leaders { + # if {$ldridx+1 > $num_leaders} { + # break + # } + # if {$leadername ne ""} { + # if {[tcl::dict::get $argstate $leadername -multiple]} { + # if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + # tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + # } else { + # tcl::dict::lappend leaders_dict $leadername $ldr + # } + # set leadername_multiple $leadername + # } else { + # tcl::dict::set leaders_dict $leadername $ldr + # } + # lappend leadernames_received $leadername + # } else { + # if {$leadername_multiple ne ""} { + # tcl::dict::lappend leaders_dict $leadername_multiple $ldr + # lappend leadernames_received $leadername_multiple ;#deliberately allow dups! (as with opts and values) + # } else { + # tcl::dict::set leaders_dict $positionalidx $ldr + # tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + # tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + # lappend leadernames_received $positionalidx + # } + # } + # incr ldridx + # incr positionalidx + #} + set validx 0 set valname_multiple "" @@ -4488,6 +4561,7 @@ tcl::namespace::eval punk::args { #------------------------------------------ set nameidx 0 set start_position $positionalidx + #MAINTENANCE - same loop logic as for leaders for {set validx 0} {$validx < [llength $values]} {incr validx} { set valname [lindex $VAL_NAMES $nameidx] incr nameidx @@ -4546,7 +4620,7 @@ tcl::namespace::eval punk::args { lappend valnames_received $positionalidx } } - set positionalidx [expr {$start_position + $validx}] + set positionalidx [expr {$start_position + $validx + 1}] } #------------------------------------------ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.8.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.8.tm new file mode 100644 index 00000000..0147636c --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.8.tm @@ -0,0 +1,6653 @@ +# -*- 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.8 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.8] +#[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 %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...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + 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: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -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. + -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) + + + " + -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 + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + #It may have aliases by separating them with a pipe | + -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\" + #The following option defines a flag style option (solo) + -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 + #Items that don't begin with * or - are value definitions + 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 leaderspec_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 optspec_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 valspec_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 ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_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]] + } 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::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # 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::define @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::define - @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 - + -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 { + #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 { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + 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\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + 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::define - @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::define - 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::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' 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 { + 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 + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - 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::define - 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::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + 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 + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - 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::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } 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::define - 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::define - 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 { + #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. + } + } 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" + } + 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] + } + } + } + -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -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 + } + -default { + tcl::dict::set spec_merged -default $specval + if {![dict exists $argdef_values -optional]} { + tcl::dict::set spec_merged -optional 1 + } + } + -optional { + tcl::dict::set spec_merged -optional $specval + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + 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::define 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::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# 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 {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + 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 {$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 { + # 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] { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach o $optmembers { + dict set lookup_optset $o $optset + #goodargs + } + } + set full_goodargs [list] + #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname + #map -realname to full argname + foreach g $goodargs { + if {[string match -* $g] && [dict exists $lookup_optset $g]} { + lappend full_goodargs [dict get $lookup_optset $g] + } else { + lappend full_goodargs $g + } + } + set goodargs $full_goodargs + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}$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 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 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 {}] + 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] + } + 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_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + 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_test] + 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 -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + 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 + } + } + } + } ;#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]} { + 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" + + } + 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} { + 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" + 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" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + 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 + } + + #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 + #[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 exists $ARG_INFO $v -optional] && ![dict get $ARG_INFO $v -optional]} { + incr valmin + } + } + } 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 { + set optmembers [split $optset |] + lappend all_opts {*}$optmembers + foreach opt $optmembers { + dict set lookup_optset $opt $optset + } + } + set ridx 0 + set rawargs_copy $rawargs + set remaining_rawargs $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + #consider for example: LEADER_NAMES {"k v" "a b c" x} + #(i.e strides of 2 3 and 1) + #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 + set named_leader_args_max 0 + foreach ln $LEADER_NAMES { + incr named_leader_args_max [llength $ln] + } + set nameidx 0 + if {$LEADER_MAX != 0} { + for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { + set r [lindex $rawargs $ridx] + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {[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 {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $all_opts $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + if {$leader_posn_name ne ""} { + #false alarm + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + #incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + set stridelength [llength $leader_posn_name] + 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] [lindex $remaining_rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop remaining_rawargs 0] + # incr ridx + # continue + # } + #} + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + #check if enough remaining_rawargs to fill any required values + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + + #leadername may be a 'stride' of arbitrary length (e.g {"key val"} or {"key val etc"}) + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + dict incr leader_posn_names_assigned $leader_posn_name + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill even this optional leader + #rather than raise error here - perform our break (for end of leaders) and let the code below handle it + break + } + + if {$valmin > 0 && [llength $remaining_rawargs] - $stridelength <= $valmin} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values + #we still need to check if enough values for the leader itself + if {[llength $remaining_rawargs] < $stridelength} { + #not enough remaining args to fill *required* leader + break + } + + incr ridx -1 + foreach v $leader_posn_name { + incr ridx + lappend pre_values [lpop remaining_rawargs 0] + } + if {!$is_multiple} { + incr nameidx + } + 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] -1 >= $valmin} { + lappend pre_values [lpop remaining_rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop 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 + } + + 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 +#JJJ + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "remaining_rawargs: $remaining_rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $remaining_rawargs -*] >= 0} { + #at least contains flaglike things.. + 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 a [lindex $remaining_rawargs $i] + set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $remaining_rawargs 0 $i] + set post_values [lrange $remaining_rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #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 + } else { + set opt [tcl::prefix match -error "" [list {*}$all_opts --] $a] + if {$opt eq "--"} {set opt ""} + if {[dict exists $lookup_optset $opt]} { + set fullopt [dict get $lookup_optset $opt] + } else { + set fullopt "" + } + if {$fullopt ne ""} { + #e.g when fullopt eq -fg|-foreground + #-fg is an alias , -foreground is the 'api' value for the result dict + #$fullopt remains as the key in the spec + set optmembers [split $fullopt |] + set api_opt [lindex $optmembers end] + + if {![tcl::dict::get $argstate $fullopt -prefix] && $a ni $optmembers} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $all_opts" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $remaining_rawargs 0 $i-1] + #set post_values [lrange $remaining_rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #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) + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + + set flagval [lindex $remaining_rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$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 $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$api_opt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $api_opt 1 + } else { + tcl::dict::lappend opts $api_opt 1 + } + if {$api_opt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 { + #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 with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + if {$OPT_ANY} { + set newval [lindex $remaining_rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $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 $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $remaining_rawargs 0 $i-1] + set post_values [lrange $remaining_rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + 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] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + #--------------------------------------- + set ordered_opts [dict create] + set unaliased_opts [lmap v $OPT_NAMES {lindex [split $v |] end}] + #unaliased_opts is list of 'api_opt' (handle aliases of form -a1|-a2|-api_opt e.g -fg|-foreground) + 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 '-any true' opts after the defined opts + 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] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + 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 - same loop logic as for values + for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { + set leadername [lindex $LEADER_NAMES $nameidx] + incr nameidx + set ldr [lindex $leaders $ldridx] + if {$leadername ne ""} { + if {[llength $leadername] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername', but requires [llength $leadername] values" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + #current stored ldr equals defined default - don't include default in the list we build up + tcl::dict::set leaders_dict $leadername [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $strideval + } + set leadername_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $strideval + } + lappend leadernames_received $leadername + } else { + if {$leadername_multiple ne ""} { + if {[llength $leadername_multiple] == 1} { + set strideval $ldr + } else { + set strideval [list] + incr ldridx -1 + foreach v $leadername_multiple { + incr ldridx + if {$ldridx > [llength $leaders]-1} { + set msg "Bad number of leaders for %caller%. Received [llength $strideval] values ('$strideval') for '$leadername_multiple', but requires [llength $leadername_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $leadername_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $leaders $ldridx] + } + } + tcl::dict::lappend leaders_dict $leadername_multiple $strideval + #name already seen - but must add to leadernames_received anyway (as with opts and values) + lappend leadernames_received $leadername_multiple + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $ldridx + 1}] + } + + #test args parse_withdef_leader_stride - todo + #change to for loop + #foreach leadername $LEADER_NAMES ldr $leaders { + # if {$ldridx+1 > $num_leaders} { + # break + # } + # if {$leadername ne ""} { + # if {[tcl::dict::get $argstate $leadername -multiple]} { + # if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + # tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + # } else { + # tcl::dict::lappend leaders_dict $leadername $ldr + # } + # set leadername_multiple $leadername + # } else { + # tcl::dict::set leaders_dict $leadername $ldr + # } + # lappend leadernames_received $leadername + # } else { + # if {$leadername_multiple ne ""} { + # tcl::dict::lappend leaders_dict $leadername_multiple $ldr + # lappend leadernames_received $leadername_multiple ;#deliberately allow dups! (as with opts and values) + # } else { + # tcl::dict::set leaders_dict $positionalidx $ldr + # tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS + # tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + # lappend leadernames_received $positionalidx + # } + # } + # incr ldridx + # incr positionalidx + #} + + + set validx 0 + set valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## 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] { + 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 + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } 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 + } + lappend strideval [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 + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + 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 + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #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 + } + } + set positionalidx [expr {$start_position + $validx + 1}] + } + #------------------------------------------ + + 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 -anyopts 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 + #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 + } + + + #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 {argname v} $opts_and_values { + if {[string match -* $argname]} { + #get full option name such as -fg|-foreground from non-alias name such as -foreground + #if "@opts -any true" - we may have an option that wasn't defined + if {[dict exists $lookup_optset $argname]} { + set argname [dict get $lookup_optset $argname] + } + } + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + 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 type [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] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + 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 e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } 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 {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + 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 { + #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 "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $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 "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + 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 + } + + 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 + } + + #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 e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #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]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -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 e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + 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 e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + 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] + } + } + } + } + } + + #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] + } + + + 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 RST [punk::ansi::a] + } else { + set I "" + 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 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 get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + 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 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?..." + } 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?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } 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" + } + } + } + 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 "" + 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 { + lappend params [subst -nocommands -novariables $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 + } + + + #*** !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.8 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm index 509e3939..3855921a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm @@ -1479,7 +1479,7 @@ tcl::namespace::eval punk::args::tclcore { is synonymous with lindex [lindex [lindex $a 1] 2] 3 - When presented with a single indes, the lindex command treats list as a Tcl list + When presented with a single index, the lindex command treats list as a Tcl list and returns the index'th element from it (0 refers to the first element of the list). In extracting the element, lindex observes the same rules concerning braces and quotes and backslashes as the Tcl command interpreter; however, @@ -1593,7 +1593,7 @@ tcl::namespace::eval punk::args::tclcore { "tcl list as a value" first -type indexexpression -help\ "index expression for first element" - last -type indexepxression -help\ + last -type indexexpression -help\ "index expression for last element" } "@doc -name Manpage: -url [manpage_tcl lrange]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -1804,7 +1804,7 @@ tcl::namespace::eval punk::args::tclcore { of the characters in ${$I}splitChars${$NI}. Empty list elements will be generated if string contains adjacent characters in ${$I}splitChars${$NI}, or if the first or last character of string is in ${$I}splitChars${$NI}. - If ${I}splitChars${$NI} is an empty string then each character of ${$I}string${$NI} + If ${$I}splitChars${$NI} is an empty string then each character of ${$I}string${$NI} becomes a separate element of the result list. ${$I}splitChars${$NI} defaults to the standard white-space characters." @values -min 1 -max 2 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tzint-1.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/tzint-1.1.1.tm new file mode 100644 index 00000000..edc4a2d6 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/tzint-1.1.1.tm @@ -0,0 +1,309 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::args::tzint 1.1.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::args::tzint 0 1.1.1] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::args::tzint] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::args::tzint +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args::tzint +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +tcl::namespace::eval punk::args::tzint { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::args::tzint}] + #[para] Core API functions for punk::args::tzint + #[list_begin definitions] + + variable PUNKARGS + + namespace eval argdoc { + proc get_symbologies {} { + if {[catch { + package require tzint + ::tzint::Encode symbologies + } result]} { + return + } else { + return $result + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tzint::Encode + @cmd -name "native tzint::Encode" -help\ + "" + @leaders -min 1 -max 1 + command -type string -choices {version symbologies bits eps svg xbm} + @values -min 0 -max 0 + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + lappend PUNKARGS [list { + @id -id "::tzint::Encode version" + @cmd -name "native tzint::Encode version" -help\ + "Return the version of underlying libzint" + @values -min 0 -max 0 + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + + lappend PUNKARGS [list { + @id -id "::tzint::Encode symbologies" + @cmd -name "native tzint::Encode symbologies" -help\ + "Return a list of symbology names that can be encoded. + These are values that can be supplied for the -symbology flag" + @values -min 0 -max 0 + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + + lappend PUNKARGS [list { + @dynamic + @id -id "::tzint::Encode svg" + @cmd -name "native tzint::Encode svg" + @leaders -min 2 -max 2 + #review - error msg for Encode without args is "Encode command ?name|varName data? ?-option value ...? + #This implies "varName data" is optional - but in practice it seems not to be (?) + "varName data" -type {string string} -optional 0 + @opts + -symbology -type string -choicerestricted 0 -choices {${[::punk::args::tzint::argdoc::get_symbologies]}} + -height -type integer -help\ + "The height of a 1d symbol" + -whitespace -type integer -help\ + "The amount of whitespace to the left and right of the generated barcode" + -bind -type boolean -default 0 -help\ + "tzint allows the symbol to be bound with 'boundary bars' + These bars help to prevent misreading of the symbol by corrupting + a scan if the scanning beam strays off the top or bottom of the symbol." + -box -type boolean -help\ + "Puts a border right around the symbol and its whitespace. + This option is automatically selected for ITF-14 symbols." + -border -type integer -help\ + "Specifies width of boundary or box." + -fg|-foreground -type string -default "000000" -help\ + "Foreground colour specified in RGB hexadecimal notation." + -bg|-background -type string -default "FFFFFF" -help\ + "Background colour specified in RGB hexadecimal notation." + -rotate -type integer -default 0 -choices {0 90 180 270} -help\ + "The symbol can be rotated through four orientations + by specifying one of the allowed angles of rotation." + -scale -type integer + -format -type string + -stat -type string -help\ + "variable name for status data" + #barcode specific options + #TODO - what? + -cols -type integer -help\ + "number of columns PDF417" + -vers -type integer -help\ + "option QR Code and Plessy" + -security -type integer -help\ + "error correction level PDF417 and QR Code" + -mode -type integer -help\ + "structured primary data mode Maxicode and Composite" + -primary -type string -help\ + "structured primary data Maxicode and Composite" + -notext -type boolean -help\ + "no interpretation line" + -square -type boolean -help\ + "force DataMatrix symbols to be square" + -init -type boolean -help\ + "create reader initialisation symbol Code128 and DataMatrix" + -smalltext -type boolean -help\ + "tiny interpretation line font" + #Changing the '0'/'1' character when using the bits command -- then -onchar and/or -offchar can be used + -onchar -type char + -offchar -type char + @values -min 0 -max 0 + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + + lappend PUNKARGS [list { + @dynamic + @id -id "::tzint::Encode xbm" + @cmd -name "native tzint::Encode xbm" + ${[punk::args::resolved_def -antiglobs {@id @cmd} "::tzint::Encode svg"]} + } "@doc -name Wikipage: -url {https://wiki.tcl-lang.org/page/tzint+%2D+tcl+package+for+libzint+barcode+encoding+library+%28no+Tk+needed%29}" ] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::tzint ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::args::tzint { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::args::tzint" + @package -name "punk::args::tzint" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::args::tzint + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::args::tzint + description to come.. + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::args::tzint::version" + } + proc get_topic_Contributors {} { + set authors {} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::args::tzint::about" + dict set overrides @cmd -name "punk::args::tzint::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::args::tzint + documentation for tzint package + }] \n] + dict set overrides topic -choices [list {*}[punk::args::tzint::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::args::tzint::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::args::tzint::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::args::tzint::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::args::tzint ::punk::args::tzint::argdoc +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args::tzint [tcl::namespace::eval punk::args::tzint { + variable pkg punk::args::tzint + variable version + set version 1.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm index 5492a18c4a4e1e5127065ba794f23822a9ada927..c99f99fed476ab3ffea881ad0836c07ec9c87983 100644 GIT binary patch delta 583 zcmV-N0=WH!UyEO`*BJsvm9yCy1rZW0mC9PYae=|g0RRBM2LJ#&0F$vUJ%8O)+iKh} z5PdiJ9|n`B7DJpz6T1D6%@SmJvK>~IR7+m61pj+RRyJ!dRvTyor2^mPcII}RXI99A z*dz4#bD$ot>P}f2` z;``TYL3BHcoZ^p4LeXOH*0rL7(%4WR=Xjflzy=BT(y+fjS%k(I27l6t2;6}I6ETkS z6jq8Dm!hjrC9Fl=o@c&|-3$$RpJ$?7yGx+OY-Ol}r<-*uf_B`aZPz+Xgl>^)aY7#U<`8&@-{|kEk7XOr28E0e`>$OY{Go z4Q^;;$59zrgo#OBO-=d3kVMXvKjhu`%LRwBBMrCw5YKCD8vjPU$(4~+@$u}cG#Mv8 zJKvMuua@xneEhRO+=zdh+jI8Dm75s+QFpocJ52PyW`CaXSY82>_$(X&2b1wCDw97g zDi{C%0{{R40s{b0O928D02BZK00;m^m9u#*7y%6}mC9PYae=|g0RRBMlb$Ym0xA=e Vu`VllSqj#PZh0RRBRlj|x*f8#I^eK+_Y2D49H z4D~*mrRjg9p~&(y9U@DrC5MLMfA7d@HgT|a3)?=l0^jCx&Rm^mR>+;$BJ}t)P>8I@TlLUMQ&RpooH(JOe%_3+k-teXxoCb$yjIv4h^#wa||E{_|20-S(m< z(I^CIy3Xh$VK@#we@E*E<)J8|c#Mxg4DO(fb>!|F;Yh;EB#iGz6_^JIoTA@4Xz_tG zc`|yuJCT&kGFbTWMqf6jJ)8$IPi?ACAkyyAD4e(an60iSI$W{}=ayP1`8un0eAVpg ztAvw6(PHnGwW5O3*pMH`c%49CgM@o&*xw&4LSqaQ=>!5-e_+4_#{N8ng(Swg=;Bie zYf-nyp08syLqY!ZGf}S1324?^8S>!nCi~f!9{?k9;@)wY2+>}>PO9KRx`YsxiA}>=A0{~D<0Rj{N v6aWAK2mqo4vwtlZ0S)|)$6AAqRD8<;006|3q%L{^E0Z5DW(J-U00000lywo>