You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
5314 lines
267 KiB
5314 lines
267 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-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.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::args 0 0.1.0] |
|
#[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::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g |
|
#[example { |
|
# proc dofilestuff {args} { |
|
# lassign [dict values [punk::args::get_dict { |
|
# @cmd -help "do some stuff with files e.g dofilestuff <file1> <file2> <file3>" |
|
# @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 |
|
# } $args]] 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 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 -<optionname> 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 call above may be something like: |
|
#[para] 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 |
|
#[example { |
|
# proc dofilestuff {category args} { |
|
# lassign [dict values [punk::args::get_dict { |
|
# -directory -default "" |
|
# -translation -default binary |
|
# -nocomplain -type none |
|
# @values -min 2 -max 2 |
|
# fileA -type existingfile 1 |
|
# fileB -type existingfile 1 |
|
# } $args]] 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::get_dict { |
|
# category -choices {cat1 cat2 cat3} |
|
# another_leading_arg -type boolean |
|
# } [list $category $another_leading_arg] |
|
#}] |
|
|
|
#*** !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 <procname> 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 <namepace>::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 [list] ;#fully loaded |
|
variable loaded_info [dict create] ;#time |
|
variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages |
|
variable scanned_info [dict create] ;#time and idcount |
|
#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 [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 [tcl::dict::create] ;#key on rawdef list - return dict of {-id <id> -dynamic 0|1} |
|
variable id_cache_rawdef [tcl::dict::create] |
|
variable id_cache_spec [tcl::dict::create] |
|
|
|
variable 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 [tcl::dict::create] |
|
|
|
variable 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. |
|
Returns a dictionary representing the argument specifications. |
|
|
|
The return result can generally be ignored, as the record is stored keyed on the |
|
@id -id value from the supplied definition. |
|
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 <cmd> ... |
|
|
|
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 begginning 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 and help display. |
|
directives include: |
|
%B%@id%N% ?opt val...? |
|
spec-options: -id <str> |
|
%B%@cmd%N% ?opt val...? |
|
spec-options: -name <str> -help <str> |
|
%B%@leaders%N% ?opt val...? |
|
spec-options: -min <int> -max <int> |
|
(used for leading args that come before switches/opts) |
|
%B%@opts%N% ?opt val...? |
|
spec-options: -any <bool> |
|
%B%@values%N% ?opt val...? |
|
spec-options: -min <int> -max <int> |
|
(used for trailing args that come after switches/opts) |
|
%B%@argdisplay%N% ?opt val...? |
|
spec-options: -header <str> (text for header row of table) |
|
-body <str> (text to replace autogenerated arg info) |
|
%B%@doc%N% ?opt val...? |
|
spec-options: -name <str> -url <str> |
|
%B%@seealso%N% ?opt val...? |
|
spec-options: -name <str> -url <str> (for footer - unimplemented) |
|
|
|
Some other spec-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 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 <cmd>.. function - an @id with -id <value> 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 <typename> |
|
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 |
|
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 <boolean> |
|
(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 <value> |
|
-multiple <bool> (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 {<choicelist>} |
|
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. |
|
-choicerestricted <bool> |
|
Whether values not specified in -choices or -choicegroups are |
|
allowed. Defaults to true. |
|
-choiceprefix <bool> |
|
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 {<choices>} |
|
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 {<dict>} |
|
Generally this would be used instead of -choices to allow |
|
usage display of choices grouped by some name. |
|
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. |
|
-choicemultiple <range> (default {1 1}) |
|
<range> is a pair representing min and max number of choices |
|
that can be present in the value. |
|
If <range> is a single integer it is equivalent to a <range> |
|
specified with the same integer for both min and max. |
|
Max of -1 represents no upper limit. |
|
If <range> 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 |
|
-option1 -default blah -type string |
|
#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 {}\ |
|
] |
|
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 {}\ |
|
] |
|
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 {}\ |
|
LEADER_NAMES {}\ |
|
LEADER_MIN ""\ |
|
LEADER_MAX ""\ |
|
leaderspec_defaults $leaderspec_defaults\ |
|
LEADER_CHECKS_DEFAULTS {}\ |
|
opt_default {}\ |
|
opt_required {}\ |
|
OPT_NAMES {}\ |
|
opt_any {}\ |
|
opt_solos {}\ |
|
optspec_defaults $optspec_defaults\ |
|
OPT_CHECKS_DEFAULTS {}\ |
|
val_defaults {}\ |
|
val_required {}\ |
|
VAL_NAMES {}\ |
|
val_min ""\ |
|
val_max ""\ |
|
valspec_defaults $valspec_defaults\ |
|
VAL_CHECKS_DEFAULTS {}\ |
|
argdisplay_info ""\ |
|
] |
|
|
|
#set argdata_dict [tcl::dict::create\ |
|
# id $DEF_definition_id\ |
|
# arg_info $arg_info\ |
|
# arg_checks $arg_checks\ |
|
# leader_defaults $leader_defaults\ |
|
# leader_required $leader_required\ |
|
# leader_names $leader_names\ |
|
# leader_min $leader_min\ |
|
# leader_max $leader_max\ |
|
# leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ |
|
# leader_checks_defaults $leader_checks_defaults\ |
|
# opt_defaults $opt_defaults\ |
|
# opt_required $opt_required\ |
|
# opt_names $opt_names\ |
|
# opt_any $opt_any\ |
|
# opt_solos $opt_solos\ |
|
# optspec_defaults [dict get $F $firstformid optspec_defaults]\ |
|
# opt_checks_defaults $opt_checks_defaults\ |
|
# val_defaults $val_defaults\ |
|
# val_required $val_required\ |
|
# val_names $val_names\ |
|
# val_min $val_min\ |
|
# val_max $val_max\ |
|
# valspec_defaults [dict get $F $firstformid valspec_defaults]\ |
|
# val_checks_defaults $val_checks_defaults\ |
|
# cmd_info $cmd_info\ |
|
# doc_info $doc_info\ |
|
# argdisplay_info $argdisplay_info\ |
|
# id_info $id_info\ |
|
# form_defs $F\ |
|
#] |
|
} |
|
proc define {args} { |
|
dict get [resolve {*}$args] id |
|
} |
|
proc resolve {args} { |
|
variable rawdef_cache |
|
variable id_cache_rawdef |
|
if {[dict exists $rawdef_cache $args]} { |
|
set id [dict get $rawdef_cache $args -id] |
|
set is_dynamic [dict get $rawdef_cache $args -dynamic] |
|
} else { |
|
set id [rawdef_id $args] |
|
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] |
|
} |
|
|
|
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} { |
|
set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] |
|
} |
|
} else { |
|
#we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? |
|
|
|
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 1 [list ::subst $param]] |
|
} |
|
} else { |
|
set normargs [list] |
|
foreach a $textargs { |
|
lappend normargs [tcl::string::map {\r\n \n} $a] |
|
} |
|
set optionspecs [join $normargs \n] |
|
#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 1 [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 $optionspecs]} { |
|
#resolved cache version exists |
|
return [tcl::dict::get $argdata_cache $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_required [list] |
|
set val_required [list] |
|
|
|
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 <list> ?? |
|
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 |
|
#todo argdisplay_info by fid |
|
if {![dict size $argdisplay_info]} { |
|
set argdisplay_info [dict get $copyfrom argdisplay_info] |
|
} |
|
#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] |
|
} |
|
argdisplay { |
|
#override the displayed argument table. |
|
#The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing |
|
set argdisplay_info [dict merge $argdisplay_info $at_specs] |
|
} |
|
opts { |
|
foreach fid $record_form_ids { |
|
if {[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" |
|
} |
|
dict set F $fid argspace "options" |
|
set tmp_optspec_defaults [dict get $F $fid optspec_defaults] |
|
|
|
foreach {k v} $at_specs { |
|
switch -- $k { |
|
-any - |
|
-anyopts { |
|
set 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 |
|
} |
|
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 { |
|
#allow overriding of defaults for options that occur later |
|
tcl::dict::set tmp_optspec_defaults $k $v |
|
} |
|
default { |
|
set known { -any -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\ |
|
-regexprepass -regexprefail -regexprefailmsg -validationtransform\ |
|
} |
|
error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" |
|
} |
|
} |
|
} |
|
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 { |
|
-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 { |
|
|
|
} |
|
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 |
|
} |
|
default { |
|
set known { -min -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 { |
|
} |
|
-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 |
|
} |
|
-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 |
|
} |
|
-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 { |
|
|
|
} |
|
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 -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 @argdisplay - 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 { |
|
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} { |
|
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] |
|
lappend temp_valnames $argname |
|
tcl::dict::set F $fid VAL_NAMES $temp_valnames |
|
#lappend val_names $argname |
|
} |
|
} |
|
|
|
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 |
|
} |
|
"" - 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. |
|
} |
|
lappend opt_solos $argname |
|
} 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] |
|
} |
|
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] |
|
} |
|
} |
|
} |
|
-default - -solo - -range - |
|
-choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - |
|
-minsize - -maxsize - -nocase - -optional - -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 |
|
} |
|
-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 "-<something>" |
|
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\ |
|
] |
|
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 |
|
} 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} { |
|
lappend opt_required $argname |
|
} 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 |
|
#lappend leader_required $argname |
|
} else { |
|
lappend val_required $argname |
|
} |
|
} |
|
} |
|
if {[tcl::dict::exists $spec_merged -default]} { |
|
if {$is_opt} { |
|
tcl::dict::set 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] |
|
} |
|
} |
|
} |
|
} ;# 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]" |
|
#} |
|
|
|
|
|
#check 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" |
|
} |
|
} |
|
#confirm any valnames before last don't have -multiple key |
|
foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { |
|
if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { |
|
error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" |
|
} |
|
} |
|
|
|
#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\ |
|
ARG_INFO [dict get $F $firstformid ARG_INFO]\ |
|
ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ |
|
LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ |
|
LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ |
|
LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ |
|
LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ |
|
LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ |
|
leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ |
|
LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ |
|
opt_defaults $opt_defaults\ |
|
opt_required $opt_required\ |
|
OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ |
|
opt_any $opt_any\ |
|
opt_solos $opt_solos\ |
|
optspec_defaults [dict get $F $firstformid optspec_defaults]\ |
|
OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ |
|
val_defaults $val_defaults\ |
|
val_required $val_required\ |
|
VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ |
|
val_min $val_min\ |
|
val_max $val_max\ |
|
valspec_defaults [dict get $F $firstformid valspec_defaults]\ |
|
VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ |
|
cmd_info $cmd_info\ |
|
doc_info $doc_info\ |
|
package_info $package_info\ |
|
argdisplay_info $argdisplay_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 $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 @argdisplay @seealso @leaders @opts @values leaders opts values} |
|
variable resolved_def_TYPE_CHOICEGROUPS { |
|
directives {@id @package @cmd @ref @doc @argdisplay @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 (-<flag> <newval>...) 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 { |
|
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] |
|
set included_args [punk::args::system::punklib_ldiff $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 @argdisplay} { |
|
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] |
|
} |
|
} |
|
} |
|
#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 $defaults_key] [dict get $opt_override $directive]]" |
|
dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] |
|
} else { |
|
append result \n "$directive [dict get $specdict $defaults_key]" |
|
dict set resultdict $directive [dict get $specdict $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 - @argdisplay { |
|
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] |
|
} |
|
} |
|
} |
|
@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 leaderspec_defaults] [dict get $opt_override $type]]" |
|
dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] |
|
} else { |
|
append result \n "$type [dict get $specdict leaderspec_defaults]" |
|
dict set resultdict $type [dict get $specdict 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 speclist [tcl::dict::get $id_cache_rawdef $realid] |
|
set specdict [resolve {*}$speclist] |
|
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 rdef [raw_def $id] |
|
if {$rdef eq ""} {return} |
|
return [resolve {*}$rdef] |
|
#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]] |
|
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 *}} { |
|
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 {$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 "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" |
|
-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 laout" |
|
} |
|
-scheme -choices {nocolour info error} |
|
}] ] |
|
|
|
#basic 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::get_dict {@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? |
|
# |
|
|
|
|
|
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+ |
|
} |
|
} |
|
#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 returntype table ;#table as string |
|
set as_error 1 ;#usual case is to raise an error |
|
set scheme error |
|
dict for {k v} $args { |
|
set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] |
|
switch -- $fullk { |
|
-badarg { |
|
set badarg $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 |
|
} |
|
default { |
|
set arg_error_isrunning 0 |
|
error "arg_error invalid option $k. Known_options: -badarg -return -aserror" |
|
} |
|
} |
|
} |
|
#todo - scheme - use config and iterm toml definitions etc |
|
switch -- $scheme { |
|
"" - -nocolor - -nocolour { |
|
set scheme nocolour |
|
} |
|
info - error {} |
|
default { |
|
set scheme na |
|
} |
|
} |
|
#hack some basics for now. |
|
#for coloured schemes - use bold as well as brightcolour in case colour off. |
|
array set CLR {} |
|
set CLR(errormsg) [a+ brightred] |
|
set CLR(title) "" |
|
set CLR(check) [a+ brightgreen] |
|
set CLR(solo) [a+ brightcyan] |
|
set CLR(choiceprefix) [a+ underline] |
|
set CLR(badarg) [a+ brightred] |
|
set CLR(linebase_header) [a+ white] |
|
set CLR(cmdname) [a+ brightwhite] |
|
set CLR(groupname) [a+ bold] |
|
set CLR(ansiborder) [a+ bold] |
|
set CLR(ansibase_header) [a+ bold] |
|
set CLR(ansibase_body) [a+ white] |
|
|
|
switch -- $scheme { |
|
nocolour { |
|
set CLR(errormsg) [a+ bold] |
|
set CLR(title) [a+ bold] |
|
set CLR(check) "" |
|
set CLR(solo) "" |
|
set CLR(badarg) [a+ reverse] ;#? experiment |
|
set CLR(cmdname) [a+ bold] |
|
set CLR(linebase_header) "" |
|
set CLR(linebase) "" |
|
set CLR(ansibase_body) "" |
|
} |
|
info { |
|
set CLR(errormsg) [a+ brightred bold] |
|
set CLR(title) [a+ brightyellow bold] |
|
set CLR(check) [a+ brightgreen bold] |
|
set CLR(choiceprefix) [a+ brightgreen bold] |
|
set CLR(groupname) [a+ cyan bold] |
|
set CLR(ansiborder) [a+ brightcyan bold] |
|
set CLR(ansibase_header) [a+ cyan] |
|
set CLR(ansibase_body) [a+ white] |
|
} |
|
error { |
|
set CLR(errormsg) [a+ brightred bold] |
|
set CLR(title) [a+ brightcyan bold] |
|
set CLR(check) [a+ brightgreen bold] |
|
set CLR(choiceprefix) [a+ brightgreen bold] |
|
set CLR(groupname) [a+ cyan bold] |
|
set CLR(ansiborder) [a+ brightyellow bold] |
|
set CLR(ansibase_header) [a+ yellow] |
|
set CLR(ansibase_body) [a+ white] |
|
} |
|
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 |
|
} |
|
|
|
|
|
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 syn [Dict_getdef $finfo -synopsis ""] |
|
if {$syn ne ""} { |
|
append synopsis $syn \n |
|
} |
|
} |
|
if {$synopsis ne ""} { |
|
set synopsis [string range $synopsis 0 end-1] |
|
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: $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 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 |
|
} |
|
|
|
set opt_names [list] |
|
set opt_names_display [list] |
|
if {[llength [dict get $spec_dict OPT_NAMES]]} { |
|
if {![catch {package require punk::trie}]} { |
|
set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] |
|
set idents [dict get [$trie shortest_idents ""] scanned] |
|
#todo - check opt_prefixdeny |
|
|
|
$trie destroy |
|
foreach c [dict get $spec_dict OPT_NAMES] { |
|
set id [dict get $idents $c] |
|
#REVIEW |
|
if {$id eq $c} { |
|
set prefix $c |
|
set tail "" |
|
} else { |
|
set idlen [string length $id] |
|
set prefix [string range $c 0 $idlen-1] |
|
set tail [string range $c $idlen end] |
|
} |
|
lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail |
|
#lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] |
|
lappend opt_names $c |
|
} |
|
} else { |
|
set opt_names [dict get $spec_dict OPT_NAMES] |
|
set opt_names_display $opt_names |
|
} |
|
} |
|
set leading_val_names [dict get $spec_dict LEADER_NAMES] |
|
set trailing_val_names [dict get $spec_dict VAL_NAMES] |
|
|
|
#dict for {argname info} [tcl::dict::get $spec_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 |
|
|
|
#display options first then values |
|
foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { |
|
lassign $argumentset argnames_display argnames |
|
|
|
foreach argshow $argnames_display arg $argnames { |
|
set arginfo [dict get $spec_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 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 cdisplay $c |
|
if {[dict exists $choicelabeldict $c]} { |
|
append cdisplay \n [dict get $choicelabeldict $c] |
|
} |
|
dict lappend formattedchoices $groupname $cdisplay |
|
} |
|
} |
|
} else { |
|
set formattedchoices $choicegroups |
|
#set formattedchoices [dict get $arginfo -choices] |
|
} |
|
} 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 cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" |
|
if {[dict exists $choicelabeldict $c]} { |
|
append cdisplay \n [dict get $choicelabeldict $c] |
|
} |
|
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 cdisplay $c |
|
if {[dict exists $choicelabeldict $c]} { |
|
append cdisplay \n [dict get $choicelabeldict $c] |
|
} |
|
dict lappend formattedchoices $groupname $cdisplay |
|
} |
|
} |
|
} else { |
|
set formattedchoices $choicegroups |
|
} |
|
|
|
} |
|
} |
|
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 |
|
} |
|
} 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" |
|
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 |
|
#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 ;) |
|
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} { |
|
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 ::punk::args::arg_error -scheme]}} { |
|
|
|
@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 |
|
set id [dict get $values id] |
|
set real_id [real_id $id] |
|
if {$real_id eq ""} { |
|
error "punk::args::usage - no such id: $id" |
|
} |
|
arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$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 <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" |
|
@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 minimal} |
|
|
|
@values -min 2 |
|
|
|
@form -form withid -synopsis "parse arglist ?-form {int|<formname>...}? ?-errorstyle <choice>? withid $id" |
|
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|<formname>...}? ?-errorstyle <choice>? withdef $def ?$def?" |
|
withdef -type literal -help\ |
|
"The literal value 'withdef'" |
|
|
|
#todo - make -dynamic <boo> 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 <bool> 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" |
|
} |
|
set parseargs [lindex $args 0] |
|
set tailargs [lrange $args 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" |
|
} 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" |
|
} |
|
set defaultopts [dict create\ |
|
-form {*}\ |
|
-errorstyle enhanced\ |
|
] |
|
set opts [dict merge $opts $defaultopts] |
|
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]" |
|
} |
|
} |
|
} |
|
switch -- $tailtype { |
|
withid { |
|
if {[llength [lrange $tailargs $split+1 end]] != 1} { |
|
error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" |
|
} |
|
set id [lindex $tailargs $split+1] |
|
#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 [lrange $tailargs $split+1 end] |
|
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 must be 'withid' or 'withdef'" |
|
} |
|
} |
|
try { |
|
set result [punk::args::get_dict {*}$deflist $parseargs] |
|
} trap {PUNKARGS} {msg opts} { |
|
#trap punk::args argument validation/parsing errors and decide here |
|
#whether to display basic error - or full usage if configured. |
|
puts stderr "PUNKARGS: $msg\n$opts" |
|
return |
|
} trap {} {msg opts} { |
|
#review |
|
#puts stderr "$msg\n$opts" |
|
#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 $opts -errorcode] [dict get $opts -errorinfo] |
|
return |
|
} |
|
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 {args} { |
|
#see arg_error regarding considerations around unhappy-path performance |
|
|
|
#consider a better API |
|
# - e.g punk::args::parse ?-flag val?... $arglist withid $id |
|
# - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? |
|
#can the above be made completely unambiguous for arbitrary arglist?? |
|
#e.g what if arglist = withdef and the first $def is also withdef ? |
|
|
|
|
|
#*** !doctools |
|
#[call [fun get_dict] [arg optionspecs] [arg rawargs]] |
|
#[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 <options_dict> values <values_dict> |
|
#[para]ARGUMENTS: |
|
#[list_begin arguments] |
|
#[arg_def multiline-string optionspecs] |
|
#[para] This a block 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 { |
|
# @opts |
|
# -opt1 -default {} |
|
# -opt2 -default { |
|
# etc |
|
# } |
|
# @values -multiple 1 |
|
#} $args |
|
|
|
set rawargs [lindex $args end] ;# args values to be parsed |
|
#we take a definition list rather than argspecs - because the definition could be dynamic |
|
set definition_args [lrange $args 0 end-1] |
|
|
|
#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 {*}$definition_args]] |
|
|
|
# ----------------------------------------------- |
|
# Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) |
|
tcl::dict::with argspecs {} ;#turn keys into vars |
|
# TODO - capitalise 'define' vars to make it a bit easier |
|
# ----------------------------------------------- |
|
|
|
#puts "-arg_info->$arg_info" |
|
set flagsreceived [list] ;#for checking if required flags satisfied |
|
#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 (--) ? |
|
set opts $opt_defaults |
|
set pre_values {} |
|
|
|
set argnames [tcl::dict::keys $ARG_INFO] |
|
set optnames [lsearch -all -inline $argnames -*] |
|
set ridx 0 |
|
set rawargs_copy $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 |
|
if {$LEADER_MAX != 0} { |
|
foreach r $rawargs_copy { |
|
if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { |
|
break |
|
} |
|
if {$ridx == [llength $LEADER_NAMES]-1} { |
|
#at last named leader |
|
set leader_posn_name [lindex $LEADER_NAMES $ridx] |
|
if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { |
|
set is_multiple 1 |
|
} |
|
} elseif {$ridx > [llength $LEADER_NAMES]-1} { |
|
#beyond names - retain name if -multiple was true |
|
if {!$is_multiple} { |
|
set leader_posn_name "" |
|
} |
|
} else { |
|
set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string |
|
} |
|
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 {} $optnames $r] |
|
if {$matchopt ne ""} { |
|
#flaglike matches a known flag - don't treat as leader |
|
break |
|
} |
|
#if {![string match -* [lindex $argnames $ridx]]} {} |
|
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] |
|
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 ""} { |
|
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 $rawargs 0]] |
|
# if {$vmatch ne ""} { |
|
# #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values |
|
# lappend pre_values [lpop rawargs 0] |
|
# incr ridx |
|
# continue |
|
# } |
|
#} |
|
|
|
#check if enough rawargs to fill any required values |
|
if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { |
|
break |
|
} else { |
|
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]} { |
|
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] |
|
dict incr leader_posn_names_assigned $leader_posn_name |
|
} |
|
} else { |
|
#unnamed leader |
|
if {$LEADER_MIN ne "" } { |
|
if {$ridx > $LEADER_MIN} { |
|
break |
|
} else { |
|
#haven't reached LEADER_MIN |
|
lappend pre_values [lpop rawargs 0] |
|
dict incr leader_posn_names_assigned $leader_posn_name |
|
} |
|
} else { |
|
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 |
|
} |
|
|
|
#assert leadermax leadermin are numeric |
|
#assert - rawargs has been reduced by leading positionals |
|
|
|
set leaders [list] |
|
set arglist {} |
|
set post_values {} |
|
#val_min, val_max |
|
#puts stderr "rawargs: $rawargs" |
|
#puts stderr "argstate: $argstate" |
|
if {[lsearch $rawargs -*] >= 0} { |
|
#at least contains flaglike things.. |
|
set maxidx [expr {[llength $rawargs] -1}] |
|
if {$val_max == -1} { |
|
set vals_total_possible [llength $rawargs] |
|
set vals_remaining_possible $vals_total_possible |
|
} else { |
|
set vals_total_possible $val_max |
|
set vals_remaining_possible $vals_total_possible |
|
} |
|
for {set i 0} {$i <= $maxidx} {incr i} { |
|
set a [lindex $rawargs $i] |
|
set remaining_args_including_this [expr {[llength $rawargs] - $i}] |
|
#lowest val_min is 0 |
|
if {$remaining_args_including_this <= $val_min} { |
|
# if current arg is -- it will pass through as a value here |
|
set arglist [lrange $rawargs 0 $i-1] |
|
set post_values [lrange $rawargs $i end] |
|
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 <= val_min already covered above |
|
if {$val_max != -1} { |
|
#finite max number of vals |
|
if {$remaining_args_including_this == $val_max} { |
|
#assume it's a value. |
|
set arglist [lrange $rawargs 0 $i-1] |
|
set post_values [lrange $rawargs $i end] |
|
} else { |
|
#assume it's an end-of-options marker |
|
lappend flagsreceived -- |
|
set arglist [lrange $rawargs 0 $i] |
|
set post_values [lrange $rawargs $i+1 end] |
|
} |
|
} else { |
|
#unlimited number of post_values accepted |
|
#treat this as eopts - we don't care if remainder look like options or not |
|
lappend flagsreceived -- |
|
set arglist [lrange $rawargs 0 $i] |
|
set post_values [lrange $rawargs $i+1 end] |
|
} |
|
break |
|
} else { |
|
set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] |
|
if {$fullopt ne ""} { |
|
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 $rawargs 0 $i-1] |
|
set post_values [lrange $rawargs $i end] |
|
break |
|
} |
|
|
|
set flagval [lindex $rawargs $i+1] |
|
if {[tcl::dict::get $argstate $fullopt -multiple]} { |
|
#don't lappend to default - we need to replace if there is a default |
|
if {$fullopt ni $flagsreceived} { |
|
tcl::dict::set opts $fullopt [list $flagval] |
|
} else { |
|
tcl::dict::lappend opts $fullopt $flagval |
|
} |
|
} else { |
|
tcl::dict::set opts $fullopt $flagval |
|
} |
|
#incr i to skip flagval |
|
incr vals_remaining_possible -2 |
|
if {[incr i] > $maxidx} { |
|
arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt |
|
} |
|
} else { |
|
#solo |
|
if {[tcl::dict::get $argstate $fullopt -multiple]} { |
|
if {$fullopt ni $flagsreceived} { |
|
#override any default - don't lappend to it |
|
tcl::dict::set opts $fullopt 1 |
|
} else { |
|
tcl::dict::lappend opts $fullopt 1 |
|
} |
|
} else { |
|
tcl::dict::set opts $fullopt 1 |
|
} |
|
incr vals_remaining_possible -1 |
|
} |
|
lappend flagsreceived $fullopt ;#dups ok |
|
} else { |
|
#unmatched option flag |
|
#comparison to val_min already done above |
|
if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { |
|
#todo - look at optspec_default and see if solo/vs opt-val pair |
|
#we may need to lookahead by 2 regarding val_max val_min |
|
|
|
#even with optany - assume an unknown within the space of possible values is a value |
|
#unmatched option in right position to be considered a value - treat like eopts |
|
#review - document that an unspecified arg within range of possible values will act like eopts -- |
|
set arglist [lrange $rawargs 0 $i-1] |
|
set post_values [lrange $rawargs $i end] |
|
break |
|
} |
|
if {$opt_any} { |
|
set newval [lindex $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 |
|
} else { |
|
tcl::dict::set opts $a $newval |
|
} |
|
if {[incr i] > $maxidx} { |
|
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 |
|
} |
|
} else { |
|
tcl::dict::set opts $a 1 |
|
} |
|
incr vals_remaining_possible -1 |
|
} |
|
lappend flagsreceived $a ;#adhoc flag as supplied |
|
} else { |
|
if {[llength $OPT_NAMES]} { |
|
set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" |
|
} else { |
|
set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" |
|
} |
|
arg_error $errmsg $argspecs -badarg $fullopt |
|
} |
|
} |
|
} |
|
} else { |
|
#not flaglike |
|
set arglist [lrange $rawargs 0 $i-1] |
|
set post_values [lrange $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 $rawargs |
|
#set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected |
|
set arglist [list] |
|
} |
|
#puts stderr "--> arglist: $arglist" |
|
#puts stderr "--> values: $values" |
|
|
|
|
|
set positionalidx 0 ;#index for unnamed positionals (both leaders and values) |
|
set ldridx 0 |
|
set in_multiple "" |
|
set leadernames_received [list] |
|
set leaders_dict $LEADER_DEFAULTS |
|
set num_leaders [llength $leaders] |
|
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 in_multiple $leadername |
|
} else { |
|
tcl::dict::set leaders_dict $leadername $ldr |
|
} |
|
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) |
|
} 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 in_multiple "" |
|
set valnames_received [list] |
|
set values_dict $val_defaults |
|
set num_values [llength $values] |
|
foreach valname $VAL_NAMES val $values { |
|
if {$validx+1 > $num_values} { |
|
break |
|
} |
|
if {$valname ne ""} { |
|
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 $val] ;#important to treat first element as a list |
|
} else { |
|
tcl::dict::lappend values_dict $valname $val |
|
} |
|
set in_multiple $valname |
|
} else { |
|
tcl::dict::set values_dict $valname $val |
|
} |
|
lappend valnames_received $valname |
|
} else { |
|
if {$in_multiple ne ""} { |
|
tcl::dict::lappend values_dict $in_multiple $val |
|
#name already seen - but must add to valnames_received anyway (as with opts and leaders) |
|
lappend valnames_received $in_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 |
|
} |
|
} |
|
incr validx |
|
incr positionalidx |
|
} |
|
|
|
if {$leadermax == -1} { |
|
#only check min |
|
if {$num_leaders < $leadermin} { |
|
arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs |
|
} |
|
} else { |
|
if {$num_leaders < $leadermin || $num_leaders > $leadermax} { |
|
if {$leadermin == $leadermax} { |
|
arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs |
|
} else { |
|
arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs |
|
} |
|
} |
|
} |
|
|
|
if {$val_max == -1} { |
|
#only check min |
|
if {$num_values < $val_min} { |
|
arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs |
|
} |
|
} else { |
|
if {$num_values < $val_min || $num_values > $val_max} { |
|
if {$val_min == $val_max} { |
|
arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs |
|
} else { |
|
arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs |
|
} |
|
} |
|
} |
|
|
|
#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]]]} { |
|
arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs |
|
} |
|
if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { |
|
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]]]} { |
|
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 { |
|
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 |
|
} |
|
|
|
#reduce our validation requirements by removing values which match defaultval or match -choices |
|
#(could be -multiple with -choicerestriction 0 where some selections match and others don't) |
|
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 |
|
|
|
|
|
switch -- [tcl::dict::get $thisarg -ARGTYPE] { |
|
leader { |
|
set dname leaders_dict |
|
} |
|
option { |
|
set dname opts |
|
} |
|
value { |
|
set dname values_dict |
|
} |
|
} |
|
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 "Option $argname for [Get_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 "Option $argname for [Get_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 "" |
|
} |
|
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]} { |
|
error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" |
|
} |
|
} |
|
} |
|
#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 { |
|
any {} |
|
list { |
|
foreach e_check $vlist_check { |
|
if {![tcl::string::is list -strict $e_check]} { |
|
arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname |
|
} |
|
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} { |
|
arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname |
|
} |
|
} |
|
-maxsize { |
|
if {$checkval ne "-1"} { |
|
if {[llength $e_check] > $checkval} { |
|
arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
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]} { |
|
set msg [tcl::dict::get $thisarg -regexprefailmsg] |
|
} else { |
|
set msg "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" |
|
} |
|
arg_error $msg $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
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]} { |
|
arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
globstring { |
|
foreach e $remaining_e { |
|
if {![regexp {[*?\[\]]} $e]} { |
|
arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
|
|
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} { |
|
arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname |
|
} |
|
} |
|
-maxsize { |
|
if {$checkval ne "-1"} { |
|
if {[tcl::string::length $e_check] > $checkval} { |
|
arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
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]} { |
|
arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname |
|
} |
|
#lowside unspecified - check only high |
|
if {$e_check > $high} { |
|
arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname |
|
} |
|
} |
|
} elseif {$high eq ""} { |
|
foreach e $vlist e_check $vlist_check { |
|
if {![tcl::string::is integer -strict $e_check]} { |
|
arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname |
|
} |
|
#highside unspecified - check only low |
|
if {$e_check < $low} { |
|
arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname |
|
} |
|
} |
|
} else { |
|
foreach e $vlist e_check $vlist_check { |
|
if {![tcl::string::is integer -strict $e_check]} { |
|
arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname |
|
} |
|
#high and low specified |
|
if {$e_check < $low || $e_check > $high} { |
|
arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
} else { |
|
foreach e_check $vlist_check { |
|
if {![tcl::string::is integer -strict $e_check]} { |
|
arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
double { |
|
foreach e $vlist e_check $vlist_check { |
|
if {![tcl::string::is double -strict $e_check]} { |
|
error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" |
|
} |
|
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} { |
|
arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
bool { |
|
foreach e_check $vlist_check { |
|
if {![tcl::string::is boolean -strict $e_check]} { |
|
arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
dict { |
|
foreach e_check $vlist_check { |
|
if {[llength $e_check] %2 != 0} { |
|
arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname |
|
} |
|
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} { |
|
arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname |
|
} |
|
} |
|
-maxsize { |
|
if {$checkval ne "-1"} { |
|
if {[tcl::dict::size $e_check] > $checkval} { |
|
arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
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 $e_check]} { |
|
set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" |
|
#try trap? |
|
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result |
|
#throw ? |
|
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg |
|
arg_error $msg $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
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 ? |
|
arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname |
|
} |
|
} |
|
if {$type eq "existingfile"} { |
|
foreach e $vlist e_check $vlist_check { |
|
if {![file exists $e_check]} { |
|
arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname |
|
} |
|
} |
|
} elseif {$type eq "existingdirectory"} { |
|
foreach e $vlist e_check $vlist_check { |
|
if {![file isdirectory $e_check]} { |
|
arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
char { |
|
foreach e $vlist e_check $vlist_check { |
|
if {[tcl::string::length $e_check] != 1} { |
|
arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname |
|
} |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
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] |
|
} |
|
|
|
#proc sample1 {p1 args} { |
|
# #*** !doctools |
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
|
# #[para]Description of sample1 |
|
# return "ok" |
|
#} |
|
|
|
|
|
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] * |
|
} |
|
} |
|
|
|
|
|
#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::get_dict { |
|
@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} |
|
} $args] |
|
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 "<unavailable>" |
|
} |
|
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.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|