jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
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.
826 Commits
1 Branch
1 Tag
147 MiB
 
 
 
 
 
 
Tree: d85608d685
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'd85608d685'
${ noResults }
punkshell/src/modules/punk/args-999999.0a1.0.tm

14271 lines
789 KiB
Raw Blame History

# -*- 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 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args 0 999999.0a1.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::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g
#[example {
# proc dofilestuff {args} {
# lassign [dict values [punk::args::parse $args withdef {
# @cmd -help "do some stuff with files e.g dofilestuff <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
# }]] leaders opts values
#
# puts "translation is [dict get $opts -translation]"
# foreach f [dict values $values] {
# puts "doing stuff with file: $f"
# }
# }
#}]
#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls
#[para] - the above example would work just fine with only the -<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::parse call above may be something like:
#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt}
#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments
#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments
#[para]This could also be implemented entirely using args - and the @leaders category of arguments
#[example {
# proc dofilestuff {category args} {
# lassign [dict values [punk::args::parse $args withdef {
# @id -id ::dofilestuff
# -directory -default ""
# -translation -default binary
# -nocomplain -type none
# @values -min 2 -max 2
# fileA -type existingfile 1
# fileB -type existingfile 1
# }]] leaders opts values
# puts "$category fileA: [dict get $values fileA]"
# puts "$category fileB: [dict get $values fileB]"
# }
#}]
#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0
#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored
#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual,
#[para] or an additional call could be made to punk::args e.g
#[example {
# punk::args::parse [list $category $another_leading_arg] withdef {
# category -choices {cat1 cat2 cat3}
# another_leading_arg -type boolean
# }
#}]
#*** !doctools
#[subsection Notes]
#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution.
#[para]
#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense.
#For functions that are part of an API a package may be more suitable.
#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case)
#[example {
# proc test_switch {args} {
# set opts [dict create\\
# -return "object"\\
# -frametype "heavy"\\
# -show_edge 1\\
# -show_seps 0\\
# -x a\\
# -y b\\
# -z c\\
# -1 1\\
# -2 2\\
# -3 3\\
# ]
# foreach {k v} $args {
# switch -- $k {
# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 {
# dict set opts $k $v
# }
# default {
# error "unrecognised option '$k'. Known options [dict keys $opts]"
# }
# }
# }
# return $opts
# }
#}]
#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance.
#[para]
# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built.
# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map.
#[para]use punk::lib::show_jump_tables <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::register}]
#[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
if {![info exists loaded_packages]} {
set loaded_packages [list] ;#fully loaded
}
variable loaded_info
if {![info exists loaded_info]} {
set loaded_info [dict create] ;#time
}
variable scanned_packages
if {![info exists scanned_packages]} {
set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages
}
variable scanned_info ;#time and idcount
if {![info exists scanned_info]} {
set scanned_info [dict create]
}
#some packages, e.g punk::args::moduledoc::tclcore document other namespaces.
#when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources
variable namespace_docpackages
if {![info exists namespace_docpackages]} {
set namespace_docpackages [dict create]
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::args::register ---}]
}
tcl::namespace::eval ::punk::args {}
#lib & system namespaces must exist for the private namespace path below (populated further down)
tcl::namespace::eval ::punk::args::lib {}
tcl::namespace::eval ::punk::args::system {}
tcl::namespace::eval ::punk::args::private {
#Internal implementation helpers - not part of the punk::args API and not exported.
#Naming: no underscore prefix - the namespace itself denotes internal status.
#The namespace path allows unqualified calls to siblings in punk::args and its lib/system namespaces
#(mirroring the path set on ::punk::args itself at package-provide time).
tcl::namespace::path [list ::punk::args ::punk::args::lib ::punk::args::system]
}
tcl::namespace::eval ::punk::args::helpers {
variable PUNKARGS
namespace export *
lappend PUNKARGS [list {
@id -id ::punk::args::helpers::B
@cmd -name punk::args::helpers::B\
-summary\
"Return the literal ANSI SGR code for bold (a+ bold)."\
-help\
"Intended for use as a bracketed command substitution placeholder in
tstr-processed argdoc -help text, paired with a closing N call.
A literal is returned so punk::ansi presence isn't required."
@values -min 0 -max 0
}]
proc B {} {return \x1b\[1m} ;#a+ bold
lappend PUNKARGS [list {
@id -id ::punk::args::helpers::N
@cmd -name punk::args::helpers::N\
-summary\
"Return the literal ANSI SGR code for normal intensity (a+ normal)."\
-help\
"Ends a bold span opened with punk::args::helpers::B in tstr-processed
argdoc -help text."
@values -min 0 -max 0
}]
proc N {} {return \x1b\[22m} ;#a+ normal
lappend PUNKARGS [list {
@id -id ::punk::args::helpers::I
@cmd -name punk::args::helpers::I\
-summary\
"Return the literal ANSI SGR code for italic (a+ italic)."\
-help\
"Intended for use as a bracketed command substitution placeholder in
tstr-processed argdoc -help text, paired with a closing NI call.
A literal is returned so punk::ansi presence isn't required."
@values -min 0 -max 0
}]
proc I {} {return \x1b\[3m} ;#a+ italic
lappend PUNKARGS [list {
@id -id ::punk::args::helpers::NI
@cmd -name punk::args::helpers::NI\
-summary\
"Return the literal ANSI SGR code for noitalic (a+ noitalic)."\
-help\
"Ends an italic span opened with punk::args::helpers::I in
tstr-processed argdoc -help text."
@values -min 0 -max 0
}]
proc NI {} {return \x1b\[23m} ;#a+ noitalic
#proc I {} {punk::ansi::a+ italic}
#proc B {} {punk::ansi::a+ bold}
#proc N {} {punk::ansi::a+ normal}
#proc NI {} {punk::ansi::a+ italic}
lappend PUNKARGS [list {
@id -id ::punk::args::helpers::example
@cmd -name punk::args::helpers::example\
-summary\
{Display formatting for argdoc example text}\
-help\
{Wrap a block of text (e.g tcl code) in a box with optional syntax highlighting and title.
The text is processed with punk::lib::tstr to allow for command substitution and basic formatting,
but without any further dedenting (i.e it's assumed the text is already dedented appropriately
based on context).
The example function is intended for use in punk::args::define scripts to format example text in
the generated documentation, but it can be used in other contexts too.
The box is a plain grey background with a lighter grey top and bottom border.
There are no side borders so the text can be copied without extra characters getting in the way,
These top and bottom bars are implemented using unicode block characters so the bars are still
visible when ANSI is stripped.
${[punk::args::helpers::example -title "[a+ term-yellow Term-blue] Example 1 [a]" {
#A sample of an example block of text with a garish title and some basic tcl syntax highlighting.
proc test {args} {
puts "[a+ red]hello world[a]"
}
}]}
This was generated with code like the following in the punk::args::define script:
${[punk::args::helpers::example -syntax none -tstr 0 {
${[example -title "[a+ term-yellow Term-blue] Example 1 [a]" {
#A sample of an example block of text with a garish title and some basic tcl syntax highlighting.
proc test {args} {
puts "[a+ red]hello world[a]"
}
}]}
}]}
Here we eat our own dog food by nesting the example text within an ${[B]}example${[N]} call with -tstr 0
to prevent the tstr processing of the text, and -syntax none to prevent the syntax highlighting.
This allows us to show the actual code used to generate ${[a+ term-yellow Term-blue]} Example 1 ${[a+ defaultbg][a]} above without having to use any
escaping backslashes etc that may show in the output.
Note the slight indent of 2 characters on the left of the text in the example block.
This is intentional to show that the text is indented within the box, and as it's reasonably appealing
visually, explains why the -padright option defaults to padding with 2 chars on the right of the text.
see also ${[B]}punk::args::lib::tstr${[N]}
}
@opts
-padright -type integer -default 2 -help\
{Number of padding spaces to add on RHS of text block}
-syntax -type string -default tcl -choices {none tcl} -choicelabels {
tcl\
" Very basic tcl syntax highlighting
of braces,square brackets and comments."
}
-title -type string -default "" -help\
{Optional title to display in the top border of the box.
The title is overlaid on the top bar which consists of lower-half block characters.
These block characters are set with foreground black and background silver, so the lower portion
of the bar appears silver. When the title is overlaid on top of this it gets the same colouring
so that the result is black text on siver background, but full height for the width of the title text.
The title colour can be set to something other than the default black on silver by including ANSI in
the title text, but the bar on either side will still be silver.
e.g -title "[a+ term-yellow Term-blue]yellow on blue title[a]"
}
-tstr -type boolean -default 1 -help\
{By setting this to false, we can disable tstr processing of the text. This means that the text will be
treated as a literal string and any tstr variable or command substitution will not be processed.
This can be useful if you want to include text that contains tstr formatting characters or commands
without them being interpreted.}
-titlealign -type string -choices {left centre right}
text -type string
}]
proc example {args} {
#only use punk::args::parse on the unhappy path
if {[llength $args] == 0} {
punk::args::parse $args -cache 1 withid ::punk::args::helpers::example
return
}
set str [lindex $args end]
set optlist [lrange $args 0 end-1]
if {[llength $optlist] %2 != 0} {
punk::args::parse $args withid ::punk::args::helpers::example
return
}
set defaults [dict create {*}{
-padright 2
-syntax tcl
-title ""
-titlealign left
-tstr 1
}]
dict for {o v} $optlist {
switch -- $o {
-padright - -syntax - -title - -titlealign - -tstr {}
default {
return "parse error:\n[punk::args::parse $args withid ::punk::args::helpers::example]"
}
}
}
set opts [dict merge $defaults $optlist]
set opt_padright [dict get $opts -padright]
set opt_syntax [dict get $opts -syntax]
set opt_title [dict get $opts -title]
set opt_titlealign [dict get $opts -titlealign]
set opt_tstr [dict get $opts -tstr]
if {[string index $str 0] eq "\n"} {
set str [string range $str 1 end]
}
if {[string index $str end] eq "\n"} {
set str [string range $str 0 end-1]
}
#example is intended to run from a source doc that has already been dedented appropriately based on context
# - we don't want to further undent, hence -undent 0
if {$opt_tstr} {
#this is the default
set str [uplevel 1 [list punk::lib::tstr -undent 0 -return string -eval 1 -allowcommands $str]]
}
#puts stderr -------------------
#puts $str
#puts stderr -------------------
if {$opt_padright > 0} {
set str [textblock::join -- $str [string repeat " " $opt_padright]]
}
if {$opt_title ne ""} {
set title "[punk::ansi::a+ term-black Term-silver]$opt_title[punk::ansi::a]"
} else {
set title ""
}
set str [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [punk::ansi::a+ Term-grey white] -ansiborder [punk::ansi::a+ term-black Term-silver] -titlealign $opt_titlealign -title $title -boxlimits {hl} -type block $str]]
#puts stderr -------------------
#puts $str
#puts stderr -------------------
switch -- $opt_syntax {
tcl {
#rudimentary colourising (not full tcl syntax parsing)
#Note that this can highlight ;# in some places as a comment where it's not appropriate
# e.g inside a regexp
#highlight comments first - so that we can also highlight braces within comments to help with detecting unbalanced braces/square brackets in comments
#result lines often indicated in examples by \u2192 →
#however - it's not present on each line of output, instead indents are used - so we can't so easily highlight all appropriate rows(?)
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-darkgreen} {^\s*#.*} $str] ;#Note, will not highlight comments at end of line - like this one
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-darkgreen} {;\s*(#.*)} $str]
#Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between
# the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems.
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {^\{|[^\\](\{+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {[^\\](\}+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-olive} {\[|\]} $str]
#puts stderr -------------------
#puts $str
#puts stderr -------------------
}
}
set result [textblock::bookend_lines $str [punk::ansi::a] "[punk::ansi::a defaultbg] [punk::ansi::a]"]
return $result
}
lappend PUNKARGS [list {
@id -id ::punk::args::helpers::strip_nodisplay_lines
@cmd -name punk::args::helpers::strip_nodisplay_lines\
-summary\
"strip #<nodisplay> lines."\
-help\
"Strip lines beginning with #<nodisplay> from the supplied text.
Whitespace prior to #<nodisplay> is ignored, and ANSI is stripped
prior to examining each line for the #<nodisplay> tag."
@values -min 1 -max 1
text -optional 0 -help\
{punk::args::define scripts must have properly balanced braces etc
as per Tcl rules.
Sometimes it is desired to display help text or examples demonstrating
unbalanced braces etc, but without escaping it in a way that shows the
escaping backslash in the help text. This balancing requirement includes
curly braces in comments. eg
${[punk::args::helpers::example -title " Example 1a " {
proc bad_syntax {args} {
#eg this is an unbalanced left curly brace {
#<nodisplay> balancing right curly brace }
return $args
}
}]}
There is a second comment line in the above proc which begins
with #<nodisplay> and contains the balancing right curly brace.
This shouldn't show in the example above.
The actual text is in a placeholder call to punk::args::helpers::example
to provide basic syntax highlighting and box background, and looks like
the following, but without the left-hand side pipe symbols.
${[punk::args::helpers::example -syntax none -title " Example 1b " {
| proc bad_syntax {args} {
| #eg this is an unbalanced left curly brace {
| #<nodisplay> balancing right curly brace }
| return $args
| }
}]}
Technically a proc body can exist with an unbalanced brace in a comment
like that and would still run without issue. However, such a definition
couldn't be placed in a tcl file to be sourced, nor directly evaluated
with eval.
A #<nodisplay> comment can also be used just for commenting the help
source inline.
Note that an opening square bracket can't be balanced by a line beginning
with the # character.
The non-comment form @#<nodisplay> is available so help lines beginning
with this token will also be stripped. This can be used to 'close' a
section of text that happens to look like a command block. This should
only be used if there is some reason the opening square bracket can't
be rewritten in the help doc to be escaped with a backslash.
The ${[B]}strip_nodisplay_lines${[N]} function is called automatically
by the help text generators in punk::args, and generally shouldn't need
to be used directly, but nevertheless resides in in punk::args::helpers
alongside the ${[B]}example${[N]} function which is intended for writers
of punk::args::define scripts (command documentors) to use.
}
}]
proc strip_nodisplay_lines {text} {
set display ""
foreach ln [split $text \n] {
set stripped [string trimleft [punk::ansi::ansistrip $ln]]
if {![string match "#<nodisplay>*" $stripped] && ![string match "@#<nodisplay>*" $stripped]} {
append display $ln \n
}
}
if {[string index $display end] eq "\n"} {
set display [string range $display 0 end-1]
}
return $display
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::args {
if {[catch {
package require punk::assertion
}]} {
proc assert {args} {
#failed to load package 'punk::assertion'
}
} else {
#if 'package forget' was called on this package (e.g when loading test::punk::args) then assert may already exist in the namespace
#namespace import will fail if target exists
catch {
namespace import ::punk::assertion::assert
}
punk::assertion::active 1
}
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_about
if {![info exists rawdef_cache_about]} {
set rawdef_cache_about [tcl::dict::create] ;#key on rawdef list - return dict of {-id <id> -dynamic 0|1}
}
variable id_cache_rawdef
if {![info exists id_cache_rawdef]} {
set id_cache_rawdef [tcl::dict::create]
}
variable id_cache_spec
if {![info exists id_cache_spec]} {
set id_cache_spec [tcl::dict::create]
}
variable argdefcache_unresolved
if {![info exists argdefcache_unresolved]} {
set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params)
}
variable rawdef_cache_argdata
if {![info exists rawdef_cache_argdata]} {
set rawdef_cache_argdata [tcl::dict::create]
}
variable id_counter
if {![info exists id_counter]} {
set id_counter 0
}
#*** !doctools
#[subsection {Namespace punk::args}]
#[para] Core API functions for punk::args
#[list_begin definitions]
#todo - some sort of punk::args::cherrypick operation to get spec from an existing set
#todo - doctools output from definition
#todo? -synonym/alias ? (applies to opts only not values)
#e.g -background -aliases {-bg} -default White
#review - how to make work with trie prefix
#e.g
# -corner -aliases {-corners}
# -centre -aliases {-center -middle}
#We mightn't want the prefix to be longer just because of an alias
#we should get -co -ce and -m from the above as abbreviations
set map [list %G% \x1b\[32m %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ]
lappend PUNKARGS [list [string map $map {
@id -id ::punk::args::define
#todo @preamble -help "move large block outside of table?"
@cmd -name punk::args::define -help\
"Accepts a line-based definition of command arguments.
The definition can be supplied as a single text block or multiple as described
in the help information for 'text' below.
Returns an id which is a key to the stored definition.
The id is taken from the supplied definition's @id -id <idvalue> line, or is an
automatically created id of the form 'autoid_<int>'.
At the time define is called - just the raw text arguments are stored for the id.
When the id is first used, for example with 'punk::args::parse $args withid $id',
the raw definition is parsed into a stored specifications dictionary.
This specifications dictionary is structured for (optional) use within commands to
parse and validate the arguments - and is also used when retrieving definitions
(or parts thereof) for re-use.
This can be used purely for documentation or called within a function to parse a mix
of leading values, switches/flags and trailing values.
The overhead is favourably comparable with other argument processors - but none are
as fast as minimal code with a switch statement. For toplevel commands where a few
10s of microseconds is immaterial, the validation and automated error formatting in
a table can be well worthwhile. For inner procs requiring utmost speed, the call can
be made only on the unhappy path when basic processing determines a mismatch - or it
can be left entirely as documentation for interactive use with: i <cmd> ...
and for synopsis generation with: s <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 beginning with the # character are ignored.
All other toplevel lines must consist of a leading word followed by paired arguments.
The arguments can be spread over multiple lines and contain lines of near-arbitrary
text if they are properly braced or double quoted and Tcl escaping for inner quotes
or unbalanced braces is maintained.
The line continuation character
(\\ at the end of the line) can be used to continue the set of arguments for
a leading word.
The record-continuation token -& does the same job when it appears unquoted
as the last element on a line (trailing whitespace after it is tolerated):
the record continues on the next line, exactly as with a trailing \\.
Unlike a backslash, -& survives inside constructed (string-built)
definitions, where the building code's own quoting would consume a
backslash-newline. To pass a literal -& as a trailing value, brace or
quote it (e.g -default {-&}); a -& elsewhere on a line, or inside a braced
or quoted multi-line value, is ordinary data.
Leading words beginning with the @ character are directives controlling argument
parsing, defaults for subsequent arguments, and help display.
directives include:
%B%@dynamic%N%
Marks the definition as dynamic. It should appear as the first
non-comment record in the first text block, before @id.
Tstr interpolations such as \$\{\$var\} and \$\{[cmd]\}
are re-evaluated each time the definition is resolved.
Use this when defaults, choices, help text, or other definition
fields depend on values that can change after definition time.
Dynamic definitions have a small performance cost and can interact
with punk::args::parse -cache 1; see the parse -cache option.
%B%@normalize%N%
Bare directive (no options), conventionally placed near the top.
Opts the definition into indent normalization of BLOCK-FORM
multi-line field values - values whose first line is
whitespace-only, as authored by opening a braced literal with a
newline and indenting the content as a block. For such values the
structural first newline (and a whitespace-only trailing line)
are dropped, the content lines' common leading whitespace is
taken as the block's base indent, the first content line is
unindented fully and subsequent lines are re-based to the
standard 4-space continuation convention with deeper relative
indents preserved.
Head-form values (content starting on the first line) are never
altered: their base indent is ambiguous (uniform indent may be
deliberate relative convention), and they already follow the
absolute 4-space convention - so the directive is harmless on
conforming file-style definitions.
Fields named in a record's -unindentedfields are exempt.
Intended for constructed (string-built) definitions, which do not
get the whole-block indent treatment braced file-style sources
give records.
%B%@id%N% ?opt val...?
directive-options: -id <str>
%B%@cmd%N% ?opt val...?
directive-options: -name <str>
-summary <str>
-help <str>
%B%@leaders%N% ?opt val...?
(used for leading args that come before switches/opts)
directive-options:
-min <int> -max <int> (min and max number of leaders)
-unnamed <bool> (allow unnamed positional leaders)
-takewhenargsmodulo <int> (assign args to leaders based on modulo
of total number of args. If value is not supplied (or < 2) then
leaders are assigned based on whether configured opts are
encountered, and whether the min number of leaders and values
can be satisfied. In this case optional leaders are assigned if
the type of the argument can be matched.)
(also accepts options as defaults for subsequent leader definitions)
%B%@opts%N% ?opt val...?
directive-options: -any|-arbitrary <bool>
(also accepts options as defaults for subsequent flag definitions)
e.g -mash 1 - default to single letter flags to be mashable/combinable
(-abc instead of -a -b -c)
%B%@values%N% ?opt val...?
(used for trailing args that come after switches/opts)
directive-options: -min <int> -max <int> -unnamed <bool>
(also accepts options as defaults for subsequent value definitions)
%B%@form%N% ?opt val...?
(used for commands with multiple forms)
directive-options: -form <list> -synopsis <string>
The -synopsis value allows overriding the auto-calculated
synopsis.
%B%@formdisplay%N% ?opt val...?
directive-options: -header <str> (text for header row of table)
-body <str> (override autogenerated arg info for form)
%B%@doc%N% ?opt val...?
directive-options: -name <str> -url <str>
%B%@examples%N% ?opt val...?
directive-options: -help <str>
%B%@seealso%N% ?opt val...?
directive-options: -name <str> -url <str> (for footer - unimplemented)
%B%@instance%N% ?opt val...?
Some other options normally present on custom arguments are available
to use with the @leaders @opts @values directives to set defaults
for subsequent lines that represent your custom arguments.
These 3 directives should occur in exactly this order - but can be
repeated with custom argument lines interspersed.
An @id line can only appear once and should be the first item.
For the commandline usage to be displayed either on parsing error
or using the i <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|typenamelist>
A typenamelist represents a multi-value clause where each
value must match the specified type in order. This is not
valid for flags - which can only take a single value.
typename and entries in typenamelist can take 2 forms:
1) basic form: elements of llength 1 such as a simple type,
or a pipe-delimited set of type-alternates.
e.g for a single typename:
-type int, -type int|char, -type int|literal(abc)
e.g for a typenamelist
-type {int double}, -type {int|char double}
2) special form: elements of variable length
e.g for a single typename:
-type {{literal |}}
-type {{literal | | literal (}}
e.g for a typenamelist
-type {{literal |} {stringstartswith abc | int}}
The 2 forms can be mixed:
-type {{literal |} {stringstartswith a|c | int} literal(xyz)|int}
Defaults to string. If no other restrictions
are required, choosing -type any does the least validation.
recognised types:
any, unknown
(unvalidated - accepts anything)
none
(used for flags/switches only. Indicates this is
a 'solo' flag ie accepts no value)
Not valid as a member of a clause's typenamelist.
int, integer
number
list
regex, regexp
indexexpression
indexset
(as accepted by punk::lib::is_indexset)
dict
double
float
bool, boolean
char
file
directory
ansistring
globstring
(any of the types accepted by 'string is')
The above all perform some validation checks
string
(also any of the 'string is' types such as
xdigit, graph, punct, lower etc)
-type string on its own does not need validation,
but still checks for string-related restrictions
such as regexprefail, & minsize
literal(<string>)
(exact match for string)
literalprefix(<string>)
(tcl::prefix::match of string, other literal and literalprefix
entries specified as alternates using | are used in the
unique prefix calculation)
stringstartswith(<string>)
(value must match glob <string>*)
The value of string must not contain pipe char '|'
Note that types can be combined with | to indicate an 'or'
operation
e.g char|int
e.g literal(xxx)|literal(yyy)
e.g literalprefix(text)|literalprefix(binary)
(when all in the pipe-delimited type-alternates set are
literal or literalprefix - this is similar to the -choices
option with -choiceprefix true)
and more.. (todo - document here)
If a typenamelist is supplied and has length > 1
then -typeranges must be used instead of -range
The number of elements in -typeranges must match
the number of elements specified in -type.
-typesynopsis <typedisplay|typedisplaylist>
Must be same length as value in -type
This provides and override for synopsis display of types.
Any desired italicization must be applied manually to the
value.
-optional <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>
-mash <bool> (for flags/switches only)
Option clustering, flag stacking, option mashing
- all refer to the same thing:
Whether single letter flags can be mashed together.
E.g -abc instead of -a -b -c
This defaults to false, but can be set to true for all
single-letter flags by setting -mash true on the @opts directive.
It is an error to explicitly set -mash true on a flag that doesn't
have a single letter as part it's name.
(e.g it is ok on -f or even -f|--flag)
When such flags are combined, only the last one can take a value.
E.g with -mash true and flags -a -b and -c that take no values,
and -f that takes a value:
-abc is valid and equivalent to -a -b -c
-abcf <value> is valid and equivalent to -a -b -c -f <value>
but -afc <value> is not valid
-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)
-multipleunique <bool> (only valid if -multiple is true)
If true, when multiple values are stored against the same argument
name due to -multiple being true, the values must be unique.
If false, the same value can be stored multiple times.
-choices {<choicelist>}
A list of allowable values for an argument.
The -default value doesn't have to be in the list.
Synopsis display: a choice set of 1 to 3 members (counting
-choicegroups members) with -choicerestricted true displays
in the synopsis as unitalicised literal alternates
(e.g cancel, or left|centre|right) in the same style as
literal()/literalprefix() type-alternatives. Larger or
unrestricted choice sets display as the italicised argument
name or type, and a -typesynopsis always takes precedence.
If a -type is specified - it doesn't apply to choice members.
It will only be used for validation if the -choicerestricted
option is set to false. If all choices are specified in values
within the -choicegroups dict, it is not necessary to specify them
in the -choices list. It is effectively a simpler form of
specifying choices when no grouping is required. It is fine to
use both -choices and -choicegroups e.g specifying all in -choices
and then including only some that need grouping in -choicegroups.
-choicelabels {<dict>}
keys are the values/argument names from -choices (or equivalently
members of value entries from the -choicegroups dict)
The values in the choicelabels dict are text values, possibly
containing newlines, that are displayed below each choice.
This is commonly a very basic summary of the choice. In the
case of a subcommand it may be a usage synopsis for further
arguments.
-choicerestricted <bool>
Whether values not specified in -choices or -choicegroups are
allowed. Defaults to true.
When false, an input that matches no choice - including an
ambiguous prefix, a prefix of a -choiceprefixdenylist entry,
or a -choiceprefixreservelist word - is accepted unchanged as
an ordinary value (subject to -type validation) instead of
raising an error. This passthrough is the pattern for
arguments that mix a known choice set with free-form values
(e.g. a help topic word falling through to command lookup).
-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.
A matching prefix is normalized: the parse result contains
the full choice string, never the typed prefix - so callers
switch on canonical choice values only. The usage display
highlights each choice's minimal accepted prefix (a choice
in -choiceprefixdenylist displays fully highlighted - the
whole word is required).
-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.
A shorter prefix of a denied choice is an error when
-choicerestricted is true, and passes through as an ordinary
(non-choice) value when -choicerestricted is false - use this
to keep short words available for other purposes (e.g. with
'help' denied, h/he/hel remain free-form values).
-choiceprefixreservelist {<choices>}
These choices are additional values used in prefix calculation.
The values will not be added to the list of available choices.
A reserved word never matches: entered exactly it is an error
when -choicerestricted is true and passes through when false,
as do any shorter words it shadows into ambiguity. This gives
per-choice control of the minimum accepted prefix by reserving
phantom entries: e.g. -choices {environment}
-choiceprefixreservelist {en} means e/en do not match while
env, envi, ... environment all normalize to environment.
(To require a longer minimum, reserve each shorter form:
reserving {en env} raises the minimum to envi.)
-choicealiases {<dict>}
Dictionary mapping alias names to canonical choice names.
An alias is accepted wherever its canonical choice is: an
exact alias match works regardless of -choiceprefix, and
when -choiceprefix is true alias names participate in
prefix calculation so a unique prefix of an alias also
matches. A matched alias is normalized: the parse result
contains the canonical choice, never the alias.
Aliases are not displayed as separate choice entries -
usage display folds them into the canonical entry as an
'(alias: name)' note on its label. -choicelabels keys
should be canonical names only.
An alias listed in -choiceprefixdenylist must be typed
in full (denial applies to the alias name; a canonical
reached via its alias is not subject to the canonical's
own denylist entry).
Each alias must map to an existing choice, and must not
itself collide with a choice (validated when the
definition is resolved).
-choicegroups {<dict>}
Generally this would be used instead of -choices to allow
usage display of choices grouped by some name (or the empty
string for 'ungrouped' items which appear first).
See for example the output if 'i zlib' where choices of the
next subcommand are grouped by the names compression,channel,
streaming and checksumming. The -choices list is equivalent
to a -choicegroups dict entry where the key (groupname) is
the empty string. Both may be specified, in which case the
final list of available choices will be a union of the listed
values in -choices and the values from each choice group.
Choice values specified in -choices are effectively ungrouped
unless overridden by placing them in a choicegroup.
-choicemultiple <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.
-choicemultipleunique <bool> (default 0)
If choicemultiple is set to allow more than one choice, this
option specifies whether the choices must be unique within the
value list. If true, the same choice can't be selected more than
once. If false, the same choice can be selected multiple times.
-choicemultipleuniqueset <bool> (default 0)
Only applies if -choicemultiple is true and -multiple is true.
If choicemultiple is set to allow more than one choice, and
-multiple is true, this option specifies whether the sets of
choices must be unique across multiple occurrences of the argument.
If true, the same set of choices can't be selected more than once
across multiple occurrences of the multi-choice argument.
If false, the same set of choices can be selected multiple times
across multiple occurrences of the argument.
Without this option being set true, if -multiple is true and
-multipleunique is true, then the same set of choices in a
different order would be considered unique, which may not be
desirable.
-unindentedfields {<list>}
for fields with multi-line values, tell the resolver to treat
them as unindented. ie do no indent/unindent processing of
whitespace in the values. In a definition script, these fields
should have their value strings placed with reference to the
left margin in the source code. ie all whitespace in the source
is preserved.
Valid on argument lines (e.g -help, -choicelabels) and on the
@cmd directive (-help).
-minsize (type dependant)
-maxsize (type dependant)
-mincap {only valid for regex type - min number of captures}
-maxcap {only valid for regex type - max number of captures}
-range (type dependant - only valid if -type is a single item)
-typeranges (list with same number of elements as -type)
-help <string>
for the @cmd directive - this is the main multiline description.
For an argument is the multi-line help that displays in the Help
column.
For the @examples directive this is the text for examples as
displayed with 'eg <commandname>'
The -help string can be delimited with double quotes or with
curly braces. The container determines the quoting rules,
which apply to multi-line field values generally:
Braced {...} values are fully literal: $, [] and backslash
sequences all survive as typed (\\n stays two characters,
and a bare backslash as in \\Deleted keeps its backslash).
Only tstr placeholders (when \$\{...\} content is present
anywhere in the definition block) and their backslash
escape are special.
Double-quoted \"...\" values get Tcl backslash semantics
at record parse: \\n becomes a real newline and \\\\
collapses to a single backslash - while $ and [] remain
literal. No variable or command substitution is performed
on record content outside \$\{...\} tstr placeholders.
In a tstr-processed block, escaping the placeholder's
dollar sign and braces with backslashes renders a literal
placeholder - the idiom used for the \$\{...\} examples
throughout this help text.
For cases where unbalanced braces, double quotes are to
be displayed to the user without visible backslash escapes,
see 'i ::punk::args::helpers::strip_nodisplay_lines'
"
@values -min 1 -max -1
#text should be a well-formed Tcl list
text -type list -multiple 1 -help\
{Block(s) of text representing the argument definition for a command.
At least one must be supplied. If multiple, they are joined together with \n.
Using multiple text arguments may be useful to mix curly-braced and double-quoted
strings to have finer control over interpolation when defining arguments.
(this can also be handy for sections that pull resolved definition lines
from existing definitions (by id) for re-use of argument specifications and help text)
e.g the following definition passes 2 blocks as text arguments
${[punk::args::helpers::example {
punk::args::define {
@id -id ::myns::myfunc
@cmd -name myns::myfunc -help\
"Description of command"
%G%#The following option defines an option-value pair%R%
%G%#It may have aliases by separating them with a pipe |%R%
-fg|-foreground -default blah -type string -help\
"In the result dict returned by punk::args::parse
the value used in the opts key will always be the last
entry, in this case -foreground"
%G%#The following option defines a flag style option (solo)%R%
-flag1 -default 0 -type none -help\
"Info about flag1
subsequent help lines assume indent of 4 spaces with
reference to the record start (in this case -flag1).
This line has no extra indent relative to first line 'Info about flag1'
This line indented a further 6 chars"
%G%#To disable source indent processing, add for example
%G%# -unindentedfields {-help} to the argument line
%G%#This will require aligning the -help text with reference to the left
%G%#margin in the source of the definition.
@values -min 1 -max -1
%G%#Items that don't begin with * or - are value definitions%R%
v1 -type integer -default 0
thinglist -type string -multiple 1
} "@doc -name Manpage: -url [myfunc_manpage_geturl myns::myfunc]"}]}
}
}]]
proc New_command_form {name} {
#probably faster to inline a literal dict create in the proc than to use a namespace variable
set leaderdirective_defaults [tcl::dict::create {*}{
-type any
-optional 0
-allow_ansi 1
-validate_ansistripped 0
-strip_ansi 0
-nocase 0
-choiceprefix 1
-choicerestricted 1
-choicemultiple {1 1}
-choicemultipleunique 0
-choicemultipleuniqueset 0
-unindentedfields {}
-multiple 0
-multipleunique 0
-regexprepass {}
-validationtransform {}
-ensembleparameter 0
}]
set optdirective_defaults [tcl::dict::create {*}{
-type any
-optional 1
-allow_ansi 1
-validate_ansistripped 0
-strip_ansi 0
-nocase 0
-mash 0
-choiceprefix 1
-choicerestricted 1
-choicemultiple {1 1}
-choicemultipleunique 0
-choicemultipleuniqueset 0
-unindentedfields {}
-multiple 0
-multipleunique 0
-regexprepass {}
-validationtransform {}
-prefix 1
-parsekey ""
-group ""
}]
#parsekey is name of argument to use as a key in punk::args::parse result dicts
set valdirective_defaults [tcl::dict::create {*}{
-type any
-optional 0
-allow_ansi 1
-validate_ansistripped 0
-strip_ansi 0
-nocase 0
-choiceprefix 1
-choicerestricted 1
-choicemultiple {1 1}
-choicemultipleunique 0
-choicemultipleuniqueset 0
-unindentedfields {}
-multiple 0
-multipleunique 0
-regexprepass {}
-validationtransform {}
}]
#form record can have running entries such as 'argspace' that aren't given to arg parser
#we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict
return [dict create {*}{
} argspace "leaders" {*}{
} ARG_INFO [tcl::dict::create] {*}{
} ARG_CHECKS [tcl::dict::create] {*}{
} LEADER_DEFAULTS [tcl::dict::create] {*}{
} LEADER_REQUIRED [list] {*}{
} LEADER_NAMES [list] {*}{
} LEADER_MIN "" {*}{
} LEADER_MAX "" {*}{
} LEADER_TAKEWHENARGSMODULO 0 {*}{
} LEADER_UNNAMED false {*}{
} LEADERSPEC_DEFAULTS $leaderdirective_defaults {*}{
} LEADER_CHECKS_DEFAULTS {} {*}{
} OPT_DEFAULTS [tcl::dict::create] {*}{
} OPT_REQUIRED [list] {*}{
} OPT_NAMES [list] {*}{
} OPT_ANY 0 {*}{
} OPT_MIN "" {*}{
} OPT_MAX "" {*}{
} OPT_SOLOS {} {*}{
} OPT_MASHES {} {*}{
} OPT_ALL_MASH_LETTERS {} {*}{
} OPTSPEC_DEFAULTS $optdirective_defaults {*}{
} OPT_CHECKS_DEFAULTS {} {*}{
} OPT_GROUPS {} {*}{
} VAL_DEFAULTS [tcl::dict::create] {*}{
} VAL_REQUIRED [list] {*}{
} VAL_NAMES [list] {*}{
} VAL_MIN "" {*}{
} VAL_MAX "" {*}{
} VAL_UNNAMED false {*}{
} VALSPEC_DEFAULTS $valdirective_defaults {*}{
} VAL_CHECKS_DEFAULTS {} {*}{
} FORMDISPLAY [tcl::dict::create] {*}{
}
]
}
lappend PUNKARGS [list {
@id -id ::punk::args::errorstyle
@cmd -name punk::args::errorstyle\
-summary\
"Set or query the default errorstyle (unimplemented)."\
-help\
"Set or query the running configuration's default -errorstyle,
as used by punk::args::parse when no explicit -errorstyle
option is supplied in the parse call.
NOT YET IMPLEMENTED - currently raises an error.
(review - is this an override or a default with respect to
an -errorstyle explicitly passed to punk::args::parse?)"
@values -min 0 -max 1
errorstyle -type string -optional 1 -choices {debug enhanced standard basic minimal} -help\
"New default errorstyle. If omitted, the current value is returned."
}]
proc errorstyle {args} {
#set or query the running config -errorstyle
#review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle?
error todo
}
proc define {args} {
variable rawdef_cache_about
variable id_cache_rawdef
#variable rawdef_cache_argdata
if {[dict exists $rawdef_cache_about $args]} {
return [dict get [dict get $rawdef_cache_about $args] -id]
} else {
set lvl 2
set id [rawdef_id $args $lvl]
if {[id_exists $id]} {
#we seem to be re-creating a previously defined id...
#clear any existing caches for this id
undefine $id 0
}
set is_dynamic [rawdef_is_dynamic $args]
set defspace [uplevel 1 {::tcl::namespace::current}]
dict set rawdef_cache_about $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace]
dict set id_cache_rawdef $id $args
return $id
}
}
lappend PUNKARGS [list {
@id -id ::punk::args::undefine
@cmd -name punk::args::undefine\
-summary\
"Remove a definition and its cached data by id."\
-help\
"Clears the raw definition and any resolved/cached data for the
supplied id from the punk::args caches.
The definition will no longer be retrievable by id unless redefined
(or rediscovered via update_definitions if it lives in a registered
namespace's PUNKARGS variable).
Emits a note to stderr unless quiet is true."
@values -min 1 -max 2
id -type string -help\
"id of the definition to remove (as shown by punk::args::get_ids)"
quiet -type boolean -default 0 -optional 1 -help\
"Suppress stderr notices about clearing/missing ids"
}]
proc undefine {id {quiet 0}} {
#review - alias?
variable rawdef_cache_about
variable id_cache_rawdef
variable rawdef_cache_argdata
variable argdefcache_display
if {[id_exists $id]} {
if {!$quiet} {
puts stderr "punk::args::undefine clearing existing data for id:$id"
}
if {[dict exists $id_cache_rawdef $id]} {
set deflist [dict get $id_cache_rawdef $id]
dict unset rawdef_cache_about $deflist
dict unset rawdef_cache_argdata $deflist
dict unset argdefcache_display $deflist
dict unset id_cache_rawdef $id
} else {
dict for {k v} $rawdef_cache_argdata {
if {[dict get $v id] eq $id} {
dict unset rawdef_cache_argdata $k
dict unset argdefcache_display $k
}
}
dict for {k v} $rawdef_cache_about {
if {[dict get $v -id] eq $id} {
dict unset rawdef_cache_about $k
}
}
}
} else {
if {!$quiet} {
puts stderr "punk::args::undefine unable to find id: '$id'"
}
}
}
#'punk::args::parse $args withdef $deflist' can raise parsing error after an autoid was generated
# In this case we don't see the autoid in order to delete it
lappend PUNKARGS [list {
@id -id ::punk::args::undefine_deflist
@cmd -name punk::args::undefine_deflist\
-summary\
"Remove a definition and its cached data by raw definition list."\
-help\
"Clears cached data for a definition keyed by the raw definition list
itself rather than by id. This is useful where an automatic id was
generated (e.g by 'punk::args::parse ... withdef <deflist>') and the
caller never saw the autoid in order to pass it to punk::args::undefine.
A no-op if the definition list isn't in the cache."
@values -min 1 -max 1
deflist -type list -help\
"Raw definition list (list of definition blocks) as originally supplied
to define/parse"
}]
proc undefine_deflist {deflist} {
variable rawdef_cache_about
variable id_cache_rawdef
variable rawdef_cache_argdata
variable argdefcache_display
if {[dict exists $rawdef_cache_about $deflist -id]} {
set id [dict get $rawdef_cache_about $deflist -id]
dict unset rawdef_cache_about $deflist
dict unset rawdef_cache_argdata $deflist
dict unset argdefcache_display $deflist
dict unset id_cache_rawdef $id
}
}
# -- --- --- --- --- --- --- --- --- --- ---
# G-046 display-field deferral
# Expansion of ${...} content landing in display-only fields (-help on @cmd/@examples
# and argument records, @formdisplay -header/-body) is deferred out of resolve: the
# parse spec stores inert tokens plus a DISPLAY_DEFERRED map, and display consumers
# (arg_error, eg, resolved_def) expand on demand via private::expand_display_fields.
# -choicelabels stays eager - punk::ns reads it directly from parse specs during the
# subcommand walk.
variable argdefcache_display [tcl::dict::create] ;#display-expanded specs (non-dynamic definitions), keyed by raw deflist
variable display_expanding [list] ;#definition ids currently being display-expanded (reentrancy guard)
proc private::split_definition_records {optionspecs} {
#definition text -> list of records (factored out of resolve - G-046)
#records are delimited by newlines, but multiline values are allowed if properly
#quoted/braced - 'info complete' (on ansi-stripped accumulation) finds record ends.
set records [list]
set linebuild ""
set linelist [split $optionspecs \n]
set record_base_indent "" ;#indent of first line in the record e.g a parameter or @directive record which will often have subsequent lines further indented.
#find the first record's base indent
foreach ln $linelist {
if {[tcl::string::trim $ln] eq ""} {continue}
regexp {(\s*).*} $ln _all record_base_indent
break ;#break at first non-empty
}
set in_record_continuation 0
if {[catch {package require punk::ansi} errM]} {
set has_punkansi 0
} else {
set has_punkansi 1
}
set record_id 0
set record_line 0 ;#incremented at each incomplete record, set to zero after processing a complete record
set amp_trimnext 0 ;#previous line ended with the -& record-continuation token (G-045)
foreach rawline $linelist {
if {$amp_trimnext} {
#the previous line ended with the -& record-continuation token and
#linebuild already ends with the joining space: collapse this line's
#leading whitespace, as the Tcl parser does for a backslash-newline
#continuation
set rawline [tcl::string::trimleft $rawline]
set amp_trimnext 0
}
set record_so_far [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_record [punk::ansi::ansistrip $record_so_far]
} else {
#review
#we only need to strip enough to stop interference with 'info complete'
set test_record [string map [list \x1b\[ ""] $record_so_far]
}
if {![tcl::info::complete $test_record]} {
if {$in_record_continuation} {
#trim only the whitespace corresponding to the record indent - not all whitespace on left
#this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form.
#(note string first "" $str is fast and returns -1)
if {[tcl::string::first $record_base_indent $rawline] == 0} {
set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end]
append linebuild $trimmedline \n
} else {
append linebuild $rawline \n
}
} else {
assert {$record_line == 0} punk::args::private::split_definition_records record_line
regexp {(\s*).*} $rawline _all record_base_indent
append linebuild $rawline \n
set in_record_continuation 1
}
incr record_line
} else {
#either we're on a single line record, or last line of multiline record
#G-045 record continuation: an unquoted trailing -& element continues
#the record on the next line. The token is dropped and the next line
#joins after a single space with its leading whitespace collapsed -
#exactly how the Tcl parser joins a backslash-newline continuation
#before a braced definition ever reaches this splitter - so a -& record
#assembles byte-identical to its backslash-continued equivalent.
#(Constructed/string-built definitions cannot author backslash-newline
#ergonomically - the building code's own quoting consumes it - which is
#what -& is for.) Rules: the token must be a bare word preceded by
#whitespace, or be the whole line; trailing whitespace after it is
#tolerated. A braced or double-quoted -& never matches (the raw line
#then ends with the closing delimiter) - brace a literal trailing -&
#value: {-&}. A -& inside a still-open braced/quoted value is data
#(info complete is false for those lines - handled in the branch above).
set is_ampcontinuation [regexp {(?:^|\s)-&\s*$} $rawline]
if {$is_ampcontinuation} {
regsub {\s*-&\s*$} $rawline "" rawline
}
if {$record_line != 0} {
if {[tcl::string::first $record_base_indent $rawline] == 0} {
set trimmedline [tcl::string::range $rawline [tcl::string::length $record_base_indent] end]
append linebuild $trimmedline
} else {
append linebuild $rawline
}
} else {
append linebuild $rawline
}
if {$is_ampcontinuation} {
#record continues on the next line
append linebuild " "
set amp_trimnext 1
if {$record_line == 0} {
regexp {(\s*).*} $rawline _all record_base_indent
set in_record_continuation 1
}
incr record_line
} else {
lappend records $linebuild
set linebuild ""
#prep for next record
set in_record_continuation 0
incr record_id
set record_line 0
}
}
}
if {$in_record_continuation} {
puts stderr "punk::args::resolve incomplete record:"
puts stderr "$linebuild"
}
return $records
}
proc private::rebase_multiline_value {value} {
#G-045 @normalize: re-base a BLOCK-FORM multi-line field value to the
#file-style continuation convention. Block form = the first line is
#whitespace-only (the value was authored as an indented block, e.g. a braced
#literal opening with a newline). The structural first newline (and a
#whitespace-only trailing line) are dropped, the common leading whitespace of
#the content lines is the block's base indent: the first content line is
#unindented fully and subsequent lines have the base replaced with 4 spaces
#(deeper relative indents preserved). Whitespace-only inner lines become
#empty lines.
#Head-form values (content on the first line) are returned UNCHANGED: their
#base indent is unknowable - a value whose continuations sit uniformly at 6
#may be base-4 with the deliberate +2 relative convention, or base-6 flush;
#re-basing would flatten the former. Head-form values follow the standard
#absolute convention (continuations at 4 + relative extras) as always, which
#also makes @normalize a no-op on conforming file-style definitions.
set lines [split $value \n]
if {[llength $lines] < 2} {
return $value
}
if {[tcl::string::trim [lindex $lines 0]] ne ""} {
#head form - unchanged
return $value
}
set lines [lrange $lines 1 end]
if {[llength $lines] > 1 && [tcl::string::trim [lindex $lines end]] eq ""} {
set lines [lrange $lines 0 end-1]
}
set prefix ""
set have_prefix 0
foreach ln $lines {
if {[tcl::string::trim $ln] eq ""} {continue}
regexp {^[ \t]*} $ln thisprefix
if {!$have_prefix} {
set prefix $thisprefix
set have_prefix 1
} else {
while {$prefix ne "" && [tcl::string::first $prefix $ln] != 0} {
set prefix [tcl::string::range $prefix 0 end-1]
}
}
if {$have_prefix && $prefix eq ""} {break}
}
if {!$have_prefix} {
#no content lines - degenerate block, structural lines dropped
return [join $lines \n]
}
set plen [tcl::string::length $prefix]
set out [list]
set done_first 0
foreach ln $lines {
if {[tcl::string::trim $ln] eq ""} {
lappend out ""
} elseif {!$done_first} {
#first content line - unindent fully (it starts with the common prefix)
lappend out [tcl::string::range $ln $plen end]
set done_first 1
} else {
lappend out " [tcl::string::range $ln $plen end]"
}
}
return [join $out \n]
}
proc private::normalize_records {records} {
#G-045 @normalize pre-pass (value semantics in rebase_multiline_value).
#Records are list-shaped (resolve consumes them via lassign), so a record is
#rewritten as a canonical list only when one of its values changed; fields
#named in the record's own -unindentedfields are exempt. Malformed records
#pass through untouched - resolve's record loop raises the real errors.
set out [list]
foreach rec $records {
set trimrec [tcl::string::trim $rec]
switch -- [tcl::string::index $trimrec 0] {
"" - # {
lappend out $rec
continue
}
}
if {[tcl::string::first \n $rec] < 0} {
lappend out $rec
continue
}
if {[catch {set recvalues [lassign $trimrec firstword]}]} {
lappend out $rec
continue
}
if {[llength $recvalues] % 2 != 0} {
lappend out $rec
continue
}
if {[dict exists $recvalues -unindentedfields]} {
set unindented [dict get $recvalues -unindentedfields]
} else {
set unindented {}
}
set newrec [list $firstword]
set changed 0
foreach {k v} $recvalues {
if {$k ni $unindented && [tcl::string::first \n $v] >= 0} {
set nv [rebase_multiline_value $v]
if {$nv ne $v} {
set changed 1
}
lappend newrec $k $nv
} else {
lappend newrec $k $v
}
}
if {$changed} {
lappend out $newrec
} else {
lappend out $rec
}
}
return $out
}
proc private::classify_display_tokens {placeholdertext tokenlist} {
#G-046: return the subset of tokenlist whose tokens land in display-only field
#values. Display-only: -help on @cmd/@examples and on argument records, and
#@formdisplay -header/-body. Everything else (record names, -choices, -default,
#-choicelabels, @form -synopsis, directive settings) is parse/synopsis-relevant
#and stays eagerly expanded.
set display_tokens [list]
if {![llength $tokenlist]} {
return $display_tokens
}
set records [split_definition_records $placeholdertext]
foreach rec $records {
set trimrec [tcl::string::trim $rec]
switch -- [tcl::string::index $trimrec 0] {
"" - # {continue}
}
if {[catch {set record_values [lassign $trimrec firstword]}]} {
continue ;#unparseable here - real errors surface in resolve's own record loop
}
if {[llength $record_values] % 2 != 0} {
continue
}
switch -glob -- $firstword {
@cmd - @examples {
set displaykeys {-help}
}
@formdisplay {
set displaykeys {-header -body}
}
@* {
set displaykeys {}
}
default {
#argument record
set displaykeys {-help}
}
}
if {![llength $displaykeys]} {continue}
foreach {k v} $record_values {
if {$k in $displaykeys && [string first \x01PADEFER $v] >= 0} {
foreach tk $tokenlist {
if {$tk ni $display_tokens && [string first $tk $v] >= 0} {
lappend display_tokens $tk
}
}
}
}
}
return $display_tokens
}
proc private::mask_display_params {normargs defspace is_dynamic} {
#G-046 phases 0-2: extract ${...} params without evaluation (tstr -eval 0),
#classify which land in display-only fields, and return
# [list <blocks-with-display-params-masked-by-inert-tokens> <deferred map>]
#Blocks without display params are returned untouched (original text) so the
#normal tstr path processes them bit-identically.
set blockparts [list]
set tokenlist [list]
set n 0
set phtext ""
foreach block $normargs {
if {[string first \$\{ $block] >= 0} {
lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $block] ptlist paramlist
set btokens [list]
set phblock ""
set i 0
foreach param $paramlist {
set tk [tcl::string::cat \x01 PADEFER [incr n] \x02]
append phblock [lindex $ptlist $i] $tk
lappend btokens $tk
incr i
}
append phblock [lindex $ptlist $i]
lappend blockparts [list 1 $ptlist $paramlist $btokens]
lappend tokenlist {*}$btokens
append phtext $phblock \n
} else {
lappend blockparts [list 0 {} {} {}]
append phtext $block \n
}
}
if {![llength $tokenlist]} {
return [list $normargs {}]
}
set display_tokens [classify_display_tokens $phtext $tokenlist]
if {![llength $display_tokens]} {
return [list $normargs {}]
}
set deferred [tcl::dict::create]
set outblocks [list]
foreach block $normargs bp $blockparts {
lassign $bp hasparams ptlist paramlist btokens
if {!$hasparams} {
lappend outblocks $block
continue
}
set block_display 0
foreach tk $btokens {
if {$tk in $display_tokens} {
set block_display 1
break
}
}
if {!$block_display} {
lappend outblocks $block
continue
}
set masked ""
set i 0
foreach param $paramlist tk $btokens {
append masked [lindex $ptlist $i]
if {$tk in $display_tokens} {
append masked $tk
tcl::dict::set deferred $tk [tcl::dict::create source $param defspace $defspace dynamic $is_dynamic]
} else {
#parse-relevant param - reconstruct for normal tstr evaluation
append masked [tcl::string::cat \$\{ $param \}]
}
incr i
}
append masked [lindex $ptlist $i]
lappend outblocks $masked
}
return [list $outblocks $deferred]
}
proc private::expand_display_fields {spec} {
#G-046: expand deferred display-field content of a parse spec on demand.
#Returns the spec with display fields expanded and DISPLAY_DEFERRED emptied.
#Non-dynamic expansions are cached (keyed by raw deflist); @dynamic definitions
#re-expand each call so provider changes refresh (matching resolve semantics).
if {![tcl::dict::exists $spec DISPLAY_DEFERRED]} {
return $spec
}
set map [tcl::dict::get $spec DISPLAY_DEFERRED]
if {![tcl::dict::size $map]} {
return $spec
}
set id [tcl::dict::get $spec id]
upvar ::punk::args::id_cache_rawdef id_cache_rawdef
upvar ::punk::args::rawdef_cache_about rawdef_cache_about
upvar ::punk::args::argdefcache_display argdefcache_display
set deflist ""
set spec_dynamic 0
if {[tcl::dict::exists $id_cache_rawdef $id]} {
set deflist [tcl::dict::get $id_cache_rawdef $id]
if {[tcl::dict::exists $rawdef_cache_about $deflist -dynamic]} {
set spec_dynamic [tcl::dict::get $rawdef_cache_about $deflist -dynamic]
}
}
if {!$spec_dynamic && $deflist ne "" && [tcl::dict::exists $argdefcache_display $deflist]} {
return [tcl::dict::get $argdefcache_display $deflist]
}
upvar ::punk::args::display_expanding display_expanding
if {$id in $display_expanding} {
#reentrancy: deferred content is (indirectly) rendering help for an id whose
#display expansion is already in progress. Substitute the raw ${...} sources
#instead of evaluating - resolves cleanly, never loops. Not cached.
return [expand_display_slots $spec $map raw]
}
lappend display_expanding $id
try {
set spec [expand_display_slots $spec $map eval]
} finally {
set posn [lsearch -exact $display_expanding $id]
set display_expanding [lreplace $display_expanding $posn $posn]
}
tcl::dict::set spec DISPLAY_DEFERRED {}
if {!$spec_dynamic && $deflist ne ""} {
tcl::dict::set argdefcache_display $deflist $spec
}
return $spec
}
proc private::expand_display_slots {spec map mode} {
#walk the display-only slots of a spec and expand deferred tokens in place
foreach infokey {cmd_info examples_info} {
if {[tcl::dict::exists $spec $infokey -help]} {
set v [tcl::dict::get $spec $infokey -help]
if {[string first \x01PADEFER $v] >= 0} {
tcl::dict::set spec $infokey -help [expand_deferred_text $v $map $mode]
}
}
}
tcl::dict::for {fid fdict} [tcl::dict::get $spec FORMS] {
if {[tcl::dict::exists $fdict FORMDISPLAY]} {
tcl::dict::for {k v} [tcl::dict::get $fdict FORMDISPLAY] {
if {[string first \x01PADEFER $v] >= 0} {
tcl::dict::set spec FORMS $fid FORMDISPLAY $k [expand_deferred_text $v $map $mode]
}
}
}
tcl::dict::for {argname arginfo} [tcl::dict::get $fdict ARG_INFO] {
if {[tcl::dict::exists $arginfo -help]} {
set v [tcl::dict::get $arginfo -help]
if {[string first \x01PADEFER $v] >= 0} {
tcl::dict::set spec FORMS $fid ARG_INFO $argname -help [expand_deferred_text $v $map $mode]
}
}
}
}
return $spec
}
proc private::expand_deferred_text {text map mode} {
#replace deferred display tokens in a field value.
#mode 'eval': substitute each token's ${...} source in its recorded definition
#namespace; @dynamic sources get the second substitution round (the ${$DYN_X}
#idiom). mode 'raw': substitute the raw ${...} source text (reentrancy path).
#Multiline results align continuation lines with the leading whitespace of the
#token's line - the same 'line' paramindents treatment punk::args::lib::tstr
#applies to eagerly expanded params (G-046 item 2 for the @dynamic path).
set out ""
set firstline 1
foreach ln [split $text \n] {
if {!$firstline} {
append out \n
}
set firstline 0
if {[string first \x01PADEFER $ln] < 0} {
append out $ln
continue
}
regexp {^(\s*)} $ln _all lineindent
while {[regexp -indices {\x01PADEFER[0-9]+\x02} $ln tokenposns]} {
lassign $tokenposns t0 t1
set token [string range $ln $t0 $t1]
set replacement ""
if {[tcl::dict::exists $map $token]} {
set param [tcl::dict::get $map $token source]
set defspace [tcl::dict::get $map $token defspace]
set dynamic [tcl::dict::get $map $token dynamic]
if {$defspace eq ""} {
set defspace ::
}
if {$mode eq "raw"} {
set replacement [tcl::string::cat \$\{ $param \}]
} else {
if {[catch {tcl::namespace::eval $defspace [list ::subst $param]} presult]} {
#tstr behaviour on evaluation error: substitute the raw placeholder source
set replacement [tcl::string::cat \$\{ $param \}]
} else {
if {$dynamic && [string first \$\{ $presult] >= 0} {
#@dynamic second-round substitution
lassign [punk::args::lib::tstr -return list -eval 0 -undent 0 $presult] ptlist2 paramlist2
set r2 ""
set i 0
foreach param2 $paramlist2 {
append r2 [lindex $ptlist2 $i]
if {[catch {tcl::namespace::eval $defspace [list ::subst $param2]} p2result]} {
append r2 [tcl::string::cat \$\{ $param2 \}]
} else {
append r2 $p2result
}
incr i
}
append r2 [lindex $ptlist2 $i]
set presult $r2
}
set replacement $presult
}
}
}
if {$lineindent ne "" && [string first \n $replacement] >= 0} {
set rlines [split $replacement \n]
set replacement [lindex $rlines 0]
foreach rl [lrange $rlines 1 end] {
append replacement \n $lineindent $rl
}
}
set ln [string replace $ln $t0 $t1 $replacement]
}
append out $ln
}
return $out
}
# -- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@id -id ::punk::args::resolve
@cmd -name punk::args::resolve\
-summary\
"Resolve raw definition blocks to the internal argument specification dictionary."\
-help\
"Takes one or more raw definition blocks (as would be supplied to
punk::args::define) and returns the internal specification dictionary
- the parsed/optimised structure used by the argument parser and the
usage/synopsis renderers.
Results are cached; dynamic definitions (@dynamic, or leading
'-dynamic 1' args) are re-substituted in the caller's definition
namespace as required.
Normally called indirectly (via define/parse/get_spec) - but can be
called directly for inspection of the resolved structure."
@values -min 0 -max -1
arg -type any -multiple 1 -help\
"raw definition block"
}]
proc resolve {args} {
variable rawdef_cache_about
variable id_cache_rawdef
set defspace ""
if {[dict exists $rawdef_cache_about $args]} {
set cinfo [dict get $rawdef_cache_about $args]
set id [dict get $cinfo -id]
set is_dynamic [dict get $cinfo -dynamic]
if {[dict exists $cinfo -defspace]} {
set defspace [dict get $cinfo -defspace]
}
} else {
#should we really be resolving something that hasn't been defined?
set id [rawdef_id $args]
puts stderr "Warning: punk::args::resolve called with undefined id:$id"
set is_dynamic [rawdef_is_dynamic $args]
#-defspace ???
dict set rawdef_cache_about $args [dict create -id $id -dynamic $is_dynamic]
dict set id_cache_rawdef $id $args
}
variable rawdef_cache_argdata
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 but terribly slow without an accelerator)
#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 {}
punk::args::parse {} -errorstyle minimal withid ::punk::args::define
return
}
#experimental
set LVL 2
if {!$is_dynamic} {
#todo - don't use cached version if 'colour off' vs 'colour on' different to when last resolved!
#(e.g example blocks will still have colour if previously resolved)
if {[tcl::dict::exists $rawdef_cache_argdata $cache_key]} {
return [tcl::dict::get $rawdef_cache_argdata $cache_key]
}
set normargs [list]
foreach a $textargs {
lappend normargs [tcl::string::map {\r\n \n} $a]
}
#G-046: -help section processing is sometimes expensive (e.g tcl syntax
#highlighted examples) and isn't required for parsing of arguments. Display-only
#${...} params are masked with inert tokens here and expanded on demand at
#display time (private::expand_display_fields) with a separate cache.
set deferred_display {}
lassign [private::mask_display_params $normargs $defspace 0] normargs deferred_display
set optionspecs [list]
foreach block $normargs {
if {[string first \$\{ $block] >= 0} {
if {$defspace ne ""} {
set block [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $block]]
} else {
puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)"
set block [uplevel $LVL [list ::punk::args::lib::tstr -return string -eval 1 -allowcommands $block]]
}
}
lappend optionspecs $block
}
set optionspecs [join $optionspecs \n]
#set optionspecs [join $normargs \n]
#if {[string first \$\{ $optionspecs] > 0} {
# if {$defspace ne ""} {
# #normal/desired case
# #JJJ
# #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
# #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]]
# set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $optionspecs]]
# #set optionspecs [list]
# #foreach spec $optionspecs {
# # set spec [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $spec]]
# # lappend optionspecs $spec
# #}
# } else {
# #todo - deprecate/stop from happening?
# puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)"
# set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
# }
#}
} else {
set deferred_display {}
if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} {
#cached - so first round of substitution already done
set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key]
lassign $pt_params ptlist paramlist deferred_display
set optionspecs ""
#subst is only being called on the parameters (contents of ${..})
foreach pt $ptlist param $paramlist {
if {$defspace ne ""} {
append optionspecs $pt [namespace eval $defspace [list ::subst $param]]
} else {
puts stderr "punk::args::resolve (cached) (dynamic) calling subst in [uplevel $LVL [list namespace current]] (no defspace available!)"
append optionspecs $pt [uplevel $LVL [list ::subst $param]]
}
}
} else {
set normargs [list]
foreach a $textargs {
lappend normargs [tcl::string::map {\r\n \n} $a]
}
#G-046: mask display-only ${...} params (see non-dynamic branch note).
#Masked at round 1, so display payloads (including their round-2
#${$DYN_X} providers) never run during argument resolution.
lassign [private::mask_display_params $normargs $defspace 1] normargs deferred_display
set optionspecs [list]
foreach block $normargs {
if {[string first \$\{ $block] >= 0} {
if {$defspace ne ""} {
set block [namespace eval $defspace [list ::punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $block]]
} else {
puts stderr "punk::args::resolve (dynamic) calling tstr for id:$id with no known definition space (-defspace empty)"
set block [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $block]]
}
}
lappend optionspecs $block
}
##dynamic - double substitution required.
##e.g
## set DYN_CHOICES {${[::somewhere::get_choice_list]}}
## set RED [punk::ansi::a+ bold red]
## set RST [punk::ansi::a]
## punk::args::define {
## -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}"
##}
set optionspecs [join $optionspecs \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 {
if {$defspace ne ""} {
append optionspecs $pt [namespace eval $defspace [list ::subst $param]]
} else {
append optionspecs $pt [uplevel $LVL [list ::subst $param]]
}
}
#key is the raw def, value is the list of textparts, paramparts (and the G-046 deferred display map)
tcl::dict::set argdefcache_unresolved $cache_key [list {*}$pt_params $deferred_display]
} else {
#wasn't really a 'dynamic' definition - no 2nd round parameter substitution in definition
puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required"
}
#set optionspecs [join $normargs \n]
#if {$defspace ne ""} {
# set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
# #JJJ - review
# #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -paramindents none $optionspecs]]
#}
##REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?)
#if {[string first \$\{ $optionspecs] > 0} {
# set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel
# lassign $pt_params ptlist paramlist
# set optionspecs ""
# foreach pt $ptlist param $paramlist {
# append optionspecs $pt [uplevel $LVL [list ::subst $param]]
# }
# tcl::dict::set argdefcache_unresolved $cache_key $pt_params
#}
}
#rawdef_cache_argdata should be limited in some fashion or will be a big memory leak???
#optionspecs is the complete dynamically resolved value - we're caching how that parses into args
#This means each time a dynamic call has different results we accumulate data.. this seems potentially unsustainable in some cases - REVIEW.
#in many cases we use @dynamic only to ensure latest data, even though that may change rarely - eg for ensemble /object updates
#In that case - caching makes sense.
#For some other functions, the dynamic parts may change every time - which makes caching wasteful as old values are never reused.
#we should probably cache dynamic argdata based on id, and only keep 1 or 2 entries per id.
#At the very least, these keys aren't really 'raw' - so we should use a different dict?
if {[tcl::dict::exists $rawdef_cache_argdata [list $optionspecs]]} {
#resolved cache version exists
return [tcl::dict::get $rawdef_cache_argdata [list $optionspecs]]
}
}
#we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices
#default to 1 for convenience
#checks with no default
#-minsize -maxsize -range
#default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi
#todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist
#set opt_defaults [tcl::dict::create]
#set val_defaults [tcl::dict::create]
#set opt_solos [list]
#first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end
set records [private::split_definition_records $optionspecs]
#G-045: a bare @normalize directive record opts the whole definition into
#indent normalization of multi-line field values - the treatment constructed
#(string-built) definitions don't otherwise get. Pre-pass, so values are
#already re-based when the record loop below processes them.
foreach rec $records {
if {[tcl::string::trim $rec] eq "@normalize"} {
set records [private::normalize_records $records]
break
}
}
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 credits_info {} ;#e.g see interp man CREDITS section todo - where to display?
set instance_info {}
set keywords_info {}
set examples_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
#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict
if {[catch {set record_values [lassign $trimrec firstword]}]} {
puts stdout "----------------------------------------------"
puts stderr "rec: $rec"
set ::testrecord $rec
puts stdout "----------------------------------------------"
puts "records: $records"
puts stdout "=============================================="
error "punk::args::resolve - bad optionspecs line - unable to parse first word of record '$trimrec' id:$DEF_definition_id"
}
#set record_values [lassign $trimrec firstword]
if {[llength $record_values] % 2 != 0} {
#todo - avoid raising an error - store invalid defs keyed on id
error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id"
}
# ----------------------------------------------------------
# we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway.
#We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record!
#(form_ids_active is otherwise set in the @form handling block)
#consider the following 2 line entry which is potentially dynamically included via a tstr:
# @form -form {* newform}
# @form -form {newform} -synopsis "cmd help ?stuff?"
#If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not.
#(because _default is usually 'taken over' by the first encountered form id)
#With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record
#the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record.
if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} {
set patterns [dict get $record_values -form]
set record_form_ids [list]
foreach p $patterns {
if {[regexp {[*?\[\]]} $p]} {
#isglob - only used for matching existing forms
lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p]
} else {
#don't test for existence - will define new form if necessary
lappend record_form_ids $p
}
}
#-form values could be globs that didn't match. record_form_ids could be empty..
if {[llength $record_form_ids]} {
#only rename _default if it's the sole entry
if {[dict size $F] == 1 && [dict exists $F "_default"]} {
if {"_default" ni $record_form_ids} {
#only initial form exists - but we are mentioning new ones
#first rename the _default to first encountered new form id
#(just replace whole dict with new key - same data)
set F [dict create [lindex $record_form_ids 0] [dict get $F _default]]
#assert - _default must be only entry in form_ids_active - since there's only 1 record in $F
#we are only setting active because of the rename - @form is the way to change active forms list
set form_ids_active [lindex $record_form_ids 0]
}
}
foreach fid $record_form_ids {
if {![dict exists $F $fid]} {
if {$firstword eq "@form"} {
#only @form directly supplies keys
dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]]
} else {
dict set F $fid [New_command_form $fid]
}
} else {
#update form with current record opts, except -form
if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] }
}
}
}
} else {
#missing or empty -form
set record_form_ids $form_ids_active
if {$firstword eq "@form"} {
foreach fid $form_ids_active {
dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]]
}
}
}
# ----------------------------------------------------------
set firstchar [tcl::string::index $firstword 0]
set secondchar [tcl::string::index $firstword 1]
if {$firstchar eq "@" && $secondchar ne "@"} {
set record_type "directive"
set directive_name $firstword
set at_specs $record_values
switch -- [tcl::string::range $directive_name 1 end] {
dynamic {
set is_dynamic 1
}
normalize {
#G-045 - applied as a pre-pass over the split records (values
#are already re-based by the time this arm is reached)
if {[llength $at_specs]} {
error "punk::args::resolve - @normalize takes no options @id:$DEF_definition_id"
}
}
id {
#disallow duplicate @id line ?
#review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?)
#id An id will be allocated if no id line present or the -id value is "auto"
if {[dict exists $at_specs -id]} {
set thisid [dict get $at_specs -id]
if {$thisid ni [list $id auto]} {
error "punk::args::resolve @id mismatch existing: $id vs $thisid"
}
}
set id_info $at_specs
}
ref {
#a reference within the definition
#e.g see punk::args::moduledoc::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 {
#NOTE - this is switch arm for the literal "default" (@default) - not the default arm of the switch block!
#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]} {
#G-046: expand any deferred display content of the source spec -
#its deferred map doesn't travel with the copied fields.
set copyfrom [private::expand_display_fields [get_spec [dict get $at_specs -id]]]
#we don't copy the @id info from the source
#for now we only copy across if nothing set..
#todo - bring across defaults for empty keys at targets?
#need to keep it simple enough to reason about behaviour easily..
if {[dict size $copyfrom]} {
if {![dict size $cmd_info]} {
set cmd_info [dict get $copyfrom cmd_info]
}
if {![dict size $doc_info]} {
set doc_info [dict get $copyfrom doc_info]
}
#foreach fid $record_form_ids {
# #only use elements with matching form id?
# #probably this feature mainly useful for _default anyway so that should be ok
# #cooperative doc sets specified in same file could share via known form ids too
# FORMDISPLAY has keys -header -body
# if {![dict size $F $fid $FORMDISPLAY]} {
# if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} {
# dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY]
# }
# }
# #TODO
# #create leaders opts vals depending on position of @default line?
# #options on @default line to exclude/include sets???
#}
}
}
}
form {
# arity system ?
#handle multiple parsing styles based on arities and keyword positions (and/or flags?)
#e.g see lseq manual with 3 different parsing styles.
# @form "-synopsis" is optional - and only exists in case the user really wants
# to display something different. The system should generate consistent synopses
# with appropriate italics/bracketing etc.
# For manual -synopsis - features such as italics must be manually added.
#spitballing..
#The punk::args parser should generally be able to determine the appropriate form based
#on supplied arguments, e.g automatically using argument counts and matching literals.
#We may need to support some hints for forcing more efficient -form discriminators
#
# e.g compare with -takewhenargsmodulo that is available on @leaders
#the -arities idea below is a rough one; potentially something to consider.. but
#we want to be able to support command completion.. and things like literals should probably
#take preference for partially typed commands.. as flipping to other forms based on argcount
#could be confusing. Need to match partial command to closest form automatically but allow
#user to lock in a form interactively and see mismatches (?)
#Probably the arity-ranges of a form are best calculated automatically rather than explicitly,
#otherwise we have a strong potential for misdefinition.. (conflict with defined leaders,opts,values)
#The way forward might be to calculate some 'arity' structure from the forms to aid in form-discrimination at arg parse time.
#(this is currently covered in some ways by the LEADER_MIN,LEADER_MAX,OPT_MIN,OPT_MAX,VAL_MIN,VAL_MAX members of the FORMS <fid> dict.)
# @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
#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
#e.g -name <str>
# -summary <str>
# -help <str>
#
# -cmdtype <str>
set cmd_info [dict merge $cmd_info $at_specs]
}
doc {
set doc_info [dict merge $doc_info $at_specs]
}
formdisplay {
#override the displayed argument table for the form.
#(formdisplay keys -header -body)
#The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing
foreach fid $record_form_ids {
tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs]
}
}
opts {
foreach fid $record_form_ids {
set FDICT [dict get $F $fid]
dict set F $fid {} ;#detach
if {[tcl::dict::get $FDICT argspace] eq "values"} {
error "punk::args::resolve - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id"
}
tcl::dict::set FDICT argspace "options"
set tmp_optspec_defaults [dict get $FDICT OPTSPEC_DEFAULTS]
foreach {k v} $at_specs {
switch -- $k {
-form {
#review - handled above
}
-any - -arbitrary -
-anyopts {
#set opt_any $v
tcl::dict::set FDICT OPT_ANY $v
}
-mash {
#default for single letter options that can be mashed together - e.g -a -b can be supplied as -ab if -mash is 1
#check is bool
if {![string is boolean -strict $v]} {
error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_optspec_defaults $k $v
}
-min {
dict set FDICT OPT_MIN $v
}
-max {
#if no -max explicitly specified, and llength OPT_NAMES == 0 and OPT_ANY == 0 - -max will be set to 0 below.
dict set FDICT OPT_MAX $v
}
-unindentedfields -
-minsize - -maxsize -
-choices - -choicegroups - -choicemultiple -
-choicecolumns - -choicelabels - -choiceinfo -
-choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted {
#review - only apply to certain types?
tcl::dict::set tmp_optspec_defaults $k $v
}
-nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase {
if {$v} {
set k2 -[string range $k 3 end] ;#strip 'no'
tcl::dict::unset tmp_optspec_defaults $k2
}
}
-type {
#v is a typelist
#foreach t $v {
# #validate?
#}
tcl::dict::set tmp_optspec_defaults -type $v
}
-defaultdisplaytype {
#how the -default is displayed
#-default doesn't have to be the same type as -type which validates user input that is not defaulted.
tcl::dict::set tmp_optspec_defaults -defaultdisplaytype $v
}
-parsekey {
tcl::dict::set tmp_optspec_defaults -parsekey $v
}
-group {
tcl::dict::set tmp_optspec_defaults -group $v
if {$v ne "" && ![tcl::dict::exists $FDICT OPT_GROUPS $v]} {
tcl::dict::set FDICT OPT_GROUPS $v {-parsekey {} -help {}}
}
if {$v ne ""} {
if {[tcl::dict::exists $at_specs -parsekey]} {
tcl::dict::set FDICT OPT_GROUPS $v -parsekey [tcl::dict::get $at_specs -parsekey]
}
}
}
-grouphelp {
if {![tcl::dict::exists $at_specs -group]} {
error "punk::args::resolve Bad @opt line. -group entry is required if -grouphelp is being configured. @id:$DEF_definition_id"
}
set g [tcl::dict::get $at_specs -group]
if {$g eq ""} {
error "punk::args::resolve Bad @opt line. -group non-empty value is required if -grouphelp is being configured. @id:$DEF_definition_id"
}
set groupdict [tcl::dict::get $FDICT OPT_GROUPS]
#set helprecords [tcl::dict::get $F $fid OPT_GROUPS_HELP]
if {![tcl::dict::exists $groupdict $g]} {
tcl::dict::set FDICT OPT_GROUPS $g [dict create -parsekey {} -help $v]
} else {
tcl::dict::set FDICT OPT_GROUPS $g -help $v
}
}
-range {
if {[dict exists $at_specs -type]} {
set tp [dict get $at_specs -type]
} else {
set tp [dict get $tmp_optspec_defaults -type]
}
if {[llength $tp] == 1} {
tcl::dict::set tmp_optspec_defaults -typeranges [list $v]
} else {
error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id"
}
}
-typeranges {
if {[dict exists $at_specs -type]} {
set tp [dict get $at_specs -type]
} else {
set tp [dict get $tmp_optspec_defaults -type]
}
if {[llength $tp] != [llength $v]} {
error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -typeranges has length [llength $v]. Lengths must match. @id:$DEF_definition_id"
}
tcl::dict::set tmp_optspec_defaults -typeranges $v
}
-regexprepass -
-regexprefail -
-regexprefailmsg -
-validationtransform -
-validationtransform {
#allow overriding of defaults for options that occur later
tcl::dict::set tmp_optspec_defaults $k $v
}
-optional -
-allow_ansi -
-validate_ansistripped -
-strip_ansi -
-multiple - -multipleunique -
-choicemultipleunique - -choicemultipleuniqueset -
-prefix {
#check is bool
if {![string is boolean -strict $v]} {
error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_optspec_defaults $k $v
}
default {
set known { -parsekey -group -grouphelp
-any -anyopts -mash -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo
-type -range -typeranges -default -defaultdisplaytype -typedefaults
-choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase
-unindentedfields
-nominsize -nomaxsize -norange -nochoices -nochoicelabels
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix
-multipleunique -choicemultipleunique -choicemultipleuniqueset
-regexprepass -regexprefail -regexprefailmsg -validationtransform
}
error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id"
}
}
}
tcl::dict::set FDICT OPTSPEC_DEFAULTS $tmp_optspec_defaults
tcl::dict::set F $fid $FDICT ;#reattach
} ;# end foreach record_form_ids
}
leaders {
foreach fid $record_form_ids {
if {[dict get $F $fid argspace] in [list options values]} {
error "punk::args::resolve - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id"
}
set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS]
foreach {k v} $at_specs {
switch -- $k {
-form {
#review - handled above
}
-min -
-minvalues {
if {$v < 0} {
error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id"
}
dict set F $fid LEADER_MIN $v
#if {$leader_max == 0} {
# set leader_max -1
#}
}
-max -
-maxvalues {
if {$v < -1} {
error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id"
}
dict set F $fid LEADER_MAX $v
}
-takewhenargsmodulo {
dict set F $fid LEADER_TAKEWHENARGSMODULO $v
}
-choiceprefix -
-choicerestricted {
if {![string is boolean -strict $v]} {
error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_leaderspec_defaults $k $v
}
-choiceinfo - -choicelabels {
if {![punk::args::lib::string_is_dict $v]} {
error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id"
}
tcl::dict::set tmp_leaderspec_defaults $k $v
}
-nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels {
#-choicegroups?
if {$v} {
set k2 -[string range $k 3 end] ;#strip 'no'
tcl::dict::unset tmp_leaderspec_defaults $k2
}
}
-type {
#$v is a list of types
#foreach t $v {
#validate?
#}
#switch -- $v {
# int - integer {
# set v int
# }
# char - character {
# set v char
# }
# bool - boolean {
# set v bool
# }
# dict - dictionary {
# set v dict
# }
# list {
# }
# index {
# set v indexexpression
# }
# default {
# #todo - disallow unknown types unless prefixed with custom-
# }
#}
tcl::dict::set tmp_leaderspec_defaults $k $v
}
-range {
tcl::dict::set tmp_leaderspec_defaults -range $v
}
-typeranges {
tcl::dict::set tmp_leaderspec_defaults -range $v
}
-unindentedfields -
-minsize - -maxsize -
-choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefixdenylist - -choiceprefixreservelist - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_leaderspec_defaults $k $v
}
-regexprepass -
-regexprefail -
-regexprefailmsg -
-validationtransform {
tcl::dict::set tmp_leaderspec_defaults $k $v
}
-optional -
-allow_ansi -
-validate_ansistripped -
-strip_ansi -
-multiple -
-multipleunique -
-choicemultipleunique - -choicemultipleuniqueset -
-optional {
if {![string is boolean -strict $v]} {
error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_leaderspec_defaults $k $v
}
-unnamed {
if {![string is boolean -strict $v]} {
error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id"
}
dict set F $fid LEADER_UNNAMED $v
}
-ensembleparameter {
#review
tcl::dict::set tmp_leaderspec_defaults $k $v
#error "punk::args::resolve - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments"
}
default {
set known { -min -form -minvalues -max -maxvalues
-minsize -maxsize -range
-choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo
-choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted
-nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels
-unindentedfields
-type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple
-multipleunique -choicemultipleunique -choicemultipleuniqueset
-regexprepass -regexprefail -regexprefailmsg -validationtransform
-unnamed
}
error "punk::args::resolve - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id"
}
}
}
dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults
} ;#end foreach record_form_ids
}
values {
foreach fid $record_form_ids {
dict set F $fid argspace "values"
set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS]
foreach {k v} $at_specs {
switch -- $k {
-form {
#review - handled above
}
-min -
-minvalues {
if {$v < 0} {
error "punk::args::resolve - minimum acceptable value for key '$k' in @values line is 0. got $v @id:$DEF_definition_id"
}
#set val_min $v
dict set F $fid VAL_MIN $v
}
-max -
-maxvalues {
if {$v < -1} {
error "punk::args::resolve - minimum acceptable value for key '$k' in @values line is -1 (indicating unlimited). got $v @id:$DEF_definition_id"
}
#set val_max $v
dict set F $fid VAL_MAX $v
}
-unindentedfields -
-minsize - -maxsize - -choices - -choicemultiple - -choicecolumns -
-choicelabels - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -nocase {
#review - only apply to certain types?
tcl::dict::set tmp_valspec_defaults $k $v
}
-choiceinfo - -choicegroups {
if {![punk::args::lib::string_is_dict $v]} {
error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id"
}
tcl::dict::set tmp_valspec_defaults $k $v
}
-nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels {
# -choicegroups ??
if {$v} {
set k2 -[string range $k 3 end] ;#strip 'no'
tcl::dict::unset tmp_valspec_defaults $k2
}
}
-type {
switch -- $v {
int - integer {
set v int
}
char - character {
set v char
}
bool - boolean {
set v bool
}
dict - dictionary {
set v dict
}
list {
}
index {
set v indexexpression
}
default {
#todo - disallow unknown types unless prefixed with custom-
}
}
tcl::dict::set tmp_valspec_defaults $k $v
}
-range {
tcl::dict::set tmp_valspec_defaults -range $v
}
-typeranges {
tcl::dict::set tmp_valspec_defaults -typeranges $v
}
-allow_ansi -
-validate_ansistripped -
-strip_ansi -
-multiple -
-multipleunique -
-choicemultipleunique - -choicemultipleuniqueset -
-optional {
if {![string is boolean -strict $v]} {
error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id"
}
tcl::dict::set tmp_valspec_defaults $k $v
}
-regexprepass -
-regexprefail -
-regexprefailmsg -
-validationtransform {
tcl::dict::set tmp_valspec_defaults $k $v
}
-unnamed {
if {![string is boolean -strict $v]} {
error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id"
}
dict set F $fid VAL_UNNAMED $v
}
default {
set known { -type -range -typeranges
-min -form -minvalues -max -maxvalues
-minsize -maxsize
-choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo
-choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted
-nocase
-unindentedfields
-nominsize -nomaxsize -norange -nochoices -nochoicelabels
-optional -allow_ansi -validate_ansistripped -strip_ansi -multiple
-multipleunique -choicemultipleunique -choicemultipleuniqueset
-regexprepass -regexprefail -regexprefailmsg -validationtransform
-unnamed
}
error "punk::args::resolve - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id"
}
}
}
dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults
}
}
seealso {
#todo!
#like @doc, except displays in footer, multiple - sub-table?
set seealso_info [dict merge $seealso_info $at_specs]
}
instance {
#todo!
set instance_info [dict merge $instance_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]
}
examples {
set examples_info [dict merge $examples_info $at_specs]
}
default {
error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @examples @formdisplay @normalize - use @@name if paramname needs to be @name @id:$DEF_definition_id"
}
}
#record_type directive
continue
} elseif {$firstchar eq "-"} {
set argdef_values $record_values
#Note that we can get options defined with aliases e.g "-x|-suppress"
#Here we store the full string as the argname - but in the resulting dict upon parsing it will have the final
# entry as the key for retrieval e.g {leaders {} opts {-suppress true} values {} ...}
#we can also have longopts within the list e.g "-f|--filename="
#This accepts -f <filename> or --filename=<filename>
# (but not --filename <filename>)
#if the clausemember is optional - then the flag can act as a solo, but a parameter can only be specified on the commandline with an =
#e.g "-x|--something= -type ?string?
#accepts all of:
# -x
# --something
# --something=blah
#while most longopts require the = some utilities (e.g fossil)
#accept --longname <val>
#(fossil accepts either --longopt <val> or --longopt=<val>)
#For this reason, "-f|--filename" is different to gnu-style longopt "-f|--filename="
#for "--filename=" we can specify an 'optional' clausemember using for example -type ?string?
#4? cases
#1)
#--longopt
# (not really a longopt - can only parse with --longopt <val> - [optional member not supported, but could be solo if -type none])
#2)
#--longopt=
# (gnu style longopt - parse with --longopt=<val> - solo allowed if optional member - does not support solo via -type none)
#3)
#--longopt|--longopt= -types int
# (mixed - as fossil does - parse with --longopt=<val> or --longopt <val> [optional member not supported?])
#4)
# --xxx|--longopt= -types {?int?}
#(repeating such as --longopt --longopt= not valid?)
#redundant?
#ie --longopt|--longopt= -types {?int?}
# equivalent to
# --longopt= -types {?int?}
#allow parsing -xxx only as solo and --longopt as solo or --longopt=n ?
#the above set would not cover the edge-case where we have an optional member but we don't want --longopt to be allowed solo
#e.g
#-soloname|--longopt= -types ?int?
#allows parsing "-soloname" or "--longopt" or "--longopt=n"
#but what if we want it to mean only accept:
# "-soloname" or "--longopt=n" ??
#we deliberately don't support
#--longopt -type ?type?
#or -opt -type ?type?
#as this results in ambiguities and more complexity in parsing depending on where flag occurs in args compared to positionals
#for these reasons - we can't only look for leading -- here to determine 'longopt'
set argname $firstword
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#do some basic validation here
#1 "-type none" would not be valid for "--filename="
#2 a -type can only be optional (specified as -type ?xxx?) if at least one entry in the argname has a trailing =
#3 require --longopt if has a trailing =. ie disallow -opt= ?
set has_equal 0
set optaliases [split $firstword |]
if {[lsearch $optaliases *=] >=0} {
set has_equal 1
}
#todo - if no -type specified in this flag record, we still need to check the default -type from the @opts record - which could have been
#overridden from just 'string'
if {[tcl::dict::exists $argdef_values -type]} {
set tp [tcl::dict::get $argdef_values -type]
if {[llength $tp] != 1} {
#clauselength > 1 not currently supported for flags
#e.g -myflag -type {list int}
# e.g called on commandline with cmd -myflag {a b c} 3
#review - seems an unlikely and complicating feature to allow - evidence of tools using/supporting this in the wild not known of.
error "punk::args::resolve - Multiple space-separated arguments (as indicated by -type having multiple entries) for a flag are not supported. flag $argname -type '$tp' @id:$DEF_definition_id"
}
if {$argname eq "--"} {
if {$tp ne "none"} {
#error to explicitly attempt to configure -- as a value-taking option
error "punk::args::resolve - special flag named -- cannot be configured as a value-accepting flag. set -type none or omit -type from definition. @id:$DEF_definition_id"
}
}
if {$tp eq "none"} {
if {$has_equal} {
error "punk::args::resolve - flag type 'none' (indicating non-parameter-taking flag) is not supported when any flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id"
}
} elseif {[string match {\?*\?} $tp]} {
#optional flag value
if {!$has_equal} {
error "punk::args::resolve - Optional flag parameter (as indicated by leading & trailing ?) is not supported when no flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id"
}
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
##set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS]
tcl::dict::set argdef_values -ARGTYPE option
#set all_choices [_resolve_get_record_choices]
foreach fid $record_form_ids {
set FDICT [dict get $F $fid]
dict set F $fid {} ;#detach - probably not necessary, but easier/clearer to use dict lappend on sub dict
switch -exact -- [dict get $FDICT argspace] {
leaders {
dict set FDICT argspace "options"
}
values {
error "punk::args::resolve - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id"
}
}
set record_type option
#dict set FDICT OPT_NAMES [list {*}[dict get $FDICT OPT_NAMES] $argname]
dict lappend FDICT OPT_NAMES $argname
dict set F $fid $FDICT ;#reattach
}
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 {
set FDICT [dict get $F $fid]
dict set F $fid {} ;#detach
if {[dict get $FDICT argspace] eq "leaders"} {
set record_type leader
tcl::dict::set argdef_values -ARGTYPE leader
#lappend leader_names $argname
set temp_leadernames [tcl::dict::get $FDICT LEADER_NAMES]
if {$argname ni $temp_leadernames} {
lappend temp_leadernames $argname
tcl::dict::set FDICT LEADER_NAMES $temp_leadernames
} else {
#This can happen if the definition has repeated values
error "punk::args::resolve - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id"
}
if {[dict get $FDICT LEADER_MAX] >= 0} {
if {[dict get $FDICT LEADER_MAX] < [llength $temp_leadernames]} {
puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $FDICT LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id"
dict set FDICT LEADER_MAX [llength $temp_leadernames]
}
}
} else {
set record_type value
tcl::dict::set argdef_values -ARGTYPE value
#set temp_valnames [tcl::dict::get $FDICT VAL_NAMES]
if {$argname ni [tcl::dict::get $FDICT VAL_NAMES]} {
#lappend temp_valnames $argname
#tcl::dict::set FDICT VAL_NAMES $temp_valnames
tcl::dict::lappend FDICT VAL_NAMES $argname
} else {
error "punk::args::resolve - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id"
}
#lappend val_names $argname
if {[tcl::dict::get $FDICT VAL_MAX] >= 0} {
if {[tcl::dict::get $FDICT VAL_MAX] < [llength [tcl::dict::get $FDICT VAL_NAMES]]} {
puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [tcl::dict::get $FDICT VAL_MAX] but [llength [tcl::dict::get $FDICT VAL_NAMES]] value names found @id:$DEF_definition_id"
dict set FDICT VAL_MAX [llength [tcl::dict::get $FDICT VAL_NAMES]]
}
}
}
dict set F $fid $FDICT ;#reattach
}
set is_opt 0
}
#assert - we only get here if it is a leader, value or flag specification line.
#assert argdef_values has been set to the value of record_values
foreach fid $record_form_ids {
set FDICT [dict get $F $fid]
dict set F $fid {} ;#detach
if {$is_opt} {
#OPTSPEC_DEFAULTS are the base defaults for options - these can be overridden by @opts lines
#we may still need to test some of these defaults for validity, e.g -mash true can only apply if the argname has at least one single-character alias (e.g -x or -x|--xxx)
set spec_merged [dict get $FDICT OPTSPEC_DEFAULTS]
} else {
if {[dict get $FDICT argspace] eq "values"} {
set spec_merged [dict get $FDICT VALSPEC_DEFAULTS]
} else {
set spec_merged [dict get $FDICT LEADERSPEC_DEFAULTS]
}
}
#--------------------------------------------------
#detach only values from the FDICT that we will update
set upd_OPT_REQUIRED [dict get $FDICT OPT_REQUIRED]
dict set FDICT OPT_REQUIRED {}
set upd_VAL_REQUIRED [dict get $FDICT VAL_REQUIRED]
dict set FDICT VAL_REQUIRED {}
set upd_LEADER_REQUIRED [dict get $FDICT LEADER_REQUIRED]
dict set FDICT LEADER_REQUIRED {}
set upd_OPT_DEFAULTS [dict get $FDICT OPT_DEFAULTS]
dict set FDICT OPT_DEFAULTS {}
set upd_VAL_DEFAULTS [dict get $FDICT VAL_DEFAULTS]
dict set FDICT VAL_DEFAULTS {}
set upd_LEADER_DEFAULTS [dict get $FDICT LEADER_DEFAULTS]
dict set FDICT LEADER_DEFAULTS {}
set upd_ARG_CHECKS [dict get $FDICT ARG_CHECKS]
dict set FDICT ARG_CHECKS {}
#not strictly necessary to detach FDICT members - but arguably makes code below slightly clearer, perhaps less dict lookups too?
#--------------------------------------------------
# -> argopt argval
foreach {spec specval} $argdef_values {
#literal-key switch - bytecompiled to jumpTable
switch -- $spec {
-form {}
-type {
#todo - could be a list e.g {any int literal(Test)}
#case must be preserved in literal bracketed part
set typelist [list]
foreach typespec $specval {
if {[string match {\?*\?} $typespec]} {
set tspec [string range $typespec 1 end-1]
set optional_clausemember true
} else {
set tspec $typespec
set optional_clausemember false
}
set type_alternatives [private::split_type_expression $tspec]
set normlist [list]
foreach alt $type_alternatives {
set firstword [lindex $alt 0]
set lc_firstword [tcl::string::tolower $firstword]
#normalize here so we don't have to test during actual args parsing in main function
set normtype "<type_error>" ;#assert - should be overridden in all branches of switch
switch -- $lc_firstword {
int - integer {set normtype int}
double - float {
#review - user may wish to preserve 'float' in help display - consider how best to implement
set normtype double
}
bool - boolean {set normtype bool}
char - character {set normtype char}
dict - dictionary {set normtype dict}
index - indexexpression {set normtype indexexpression}
indexset {set normtype indexset}
"" - none - solo {
if {$is_opt} {
#review - are we allowing clauses for flags?
#e.g {-flag -type {int int}}
#this isn't very tcl like, where we'd normally mark the flag with -multiple true and
# instead require calling as: -flag <int> -flag <int>
#It seems this is a reasonably rare/unlikely requirement in most commandline tools.
if {[llength $specval] > 1} {
#makes no sense to have 'none' in a clause
error "punk::args::resolve - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id"
}
#tcl::dict::set spec_merged -type none
set normtype none
if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} {
tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it.
}
} else {
#solo only valid for flags
error "punk::args::resolve - invalid -type 'none|solo' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id"
}
}
any - anything {set normtype any}
unknown {
#'unspecified' ??
set normtype unknown
}
ansi - ansistring {set normtype ansistring}
string - globstring {set normtype $lc_firstword}
packageversion {set normtype packageversion}
packagerequirement {set normtype packagerequirement}
literal {
#value was split out by private::split_type_expression
set normtype literal([lindex $alt 1])
}
literalprefix {
set normtype literalprefix([lindex $alt 1])
}
stringstartswith {
set normtype stringstartswith([lindex $alt 1])
}
stringendswith {
set normtype stringendswith([lindex $alt 1])
}
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]
#todo
set normtype $alt
}
}
lappend normlist $normtype
}
set norms [join $normlist |]
if {$optional_clausemember} {
lappend typelist ?$norms?
} else {
lappend typelist $norms
}
}
tcl::dict::set spec_merged -type $typelist
}
-typesynopsis {
set typecount [llength [tcl::dict::get $spec_merged -type]]
if {$typecount != [llength $specval]} {
error "punk::args::resolve - invalid -typesynopsis specification for argument '$argname'. -typesynopsis has [llength $specval] entries, but requires $typecount entries (one for each entry in -types. Use empty string list members for default) @id:$DEF_definition_id"
}
tcl::dict::set spec_merged -typesynopsis $specval
}
-parsekey - -group {
tcl::dict::set spec_merged $spec $specval
}
-mash {
#allow when any alt in argname is a single letter flag such s -a or -Z
#single letter flags do not have to be -type none to allow -mash to be set true.
#a mash can be supplied where the last flag in the mash is a value-taking flag.
if {$specval} {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
error "punk::args::resolve - invalid use of -mash for argument '$argname'. -mash can only be true if at least one alias in the argname is a single-letter flag (e.g -a or -Z) @id:$DEF_definition_id"
#todo - we also have to set -mash false when processing defaults from @opts if the argname doesn't contain any single-letter flags
}
}
tcl::dict::set spec_merged -mash $specval
}
-choicealiases {
#dict of alias -> canonical choice (goal G-040).
#Aliases are accepted at parse (exact, and as prefix-calculation members when
#-choiceprefix applies) and normalize to their canonical choice in the parse
#result; usage display folds them into the canonical entry.
#Cross-validation against the final choice set happens after all specs merge.
if {![punk::args::lib::string_is_dict $specval]} {
error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary of alias -> canonical-choice @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-unindentedfields -
-solo -
-choices - -choicegroups - -choicemultiple - -choicecolumns -
-choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo -
-minsize - -maxsize - -nocase - -multiple -
-multipleunique - -choicemultipleunique - -choicemultipleuniqueset -
-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
}
-mincap - -maxcap {
#todo - allow as default for @leaders, @opts and @values when default -type there is regex or regexp?
#only applies to type regex
set tp [tcl::dict::get $spec_merged -type]
if {![string match *regex* $tp]} {
error "punk::args::resolve - invalid use of '$spec' key for argument '$argname'. '$spec' only applies to arguments with a type of regex or regexp. argument has type '$tp' @id:$DEF_definition_id"
}
tcl::dict::set spec_merged $spec $specval
}
-range {
#allow simple case to be specified without additional list wrapping
#only multi-types require full list specification
#arg1 -type int -range {0 4}
#arg2 -type {int string} -range {{0 4} {"" ""}}
set typecount [llength [tcl::dict::get $spec_merged -type]]
if {$typecount == 1} {
tcl::dict::set spec_merged -typeranges [list $specval]
} else {
error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id"
}
}
-typeranges {
set typecount [llength [tcl::dict::get $spec_merged -type]]
if {$typecount != [llength $specval]} {
error "punk::args::resolve - invalid -typeranges specification for argument '$argname'. -typeranges has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id"
}
tcl::dict::set spec_merged -typeranges $specval
}
-default {
#The -default is for when the entire clause is missing
#It doesn't necessarily have to have the same number of elements as the clause {llength $typelist}
#review
tcl::dict::set spec_merged -default $specval
if {![dict exists $argdef_values -optional]} {
tcl::dict::set spec_merged -optional 1
}
}
-defaultdisplaytype {
tcl::dict::set spec_merged -defaultdisplaytype $specval
}
-typedefaults {
set typecount [llength [tcl::dict::get $spec_merged -type]]
if {$typecount != [llength $specval]} {
error "punk::args::resolve - invalid -typedefaults specification for argument '$argname'. -typedefaults has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id"
}
tcl::dict::set spec_merged -typedefaults $specval
}
-optional {
#applies to whole arg - not each -type
tcl::dict::set spec_merged -optional $specval
}
-ensembleparameter {
#applies to whole arg - not each -type
#review - only leaders?
tcl::dict::set spec_merged $spec $specval
}
-prefix {
#applies to whole arg - not each -type
#for flags/options
tcl::dict::set spec_merged $spec $specval
}
-validationtransform {
#string is dict only 8.7/9+ - use wrapper to support 8.6 also
if {![punk::args::lib::string_is_dict $specval]} {
error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id"
}
dict for {tk tv} $specval {
switch -- $tk {
-command - -function - -type - -minsize - -maxsize - -range {
}
default {
set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc?
error "punk::args::resolve - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id"
}
}
}
#TODO!
}
default {
if {[string match ref-* $spec]} {
#we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now)
#ref-xxx will override an earlier -xxx in same line. That's fine. todo - document.
if {![tcl::dict::exists $refs $specval]} {
puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)"
} else {
set targetswitch [string range $spec 3 end] ;#capture - to form flag "-<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::resolve argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)"
}
}
}
} else {
set known_argopts [list {*}{
-form -type
-parsekey -group
-range -typeranges
-default -defaultdisplaytype -typedefaults
-minsize -maxsize -choices -choicegroups
-mincap -maxcap
-choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted
-choicelabels -choiceinfo -choicealiases
-unindentedfields
-nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help
-multipleunique -choicemultipleunique -choicemultipleuniqueset
-regexprepass -regexprefail -regexprefailmsg -validationtransform
-ensembleparameter
}]
error "punk::args::resolve - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id"
}
}
}
} ;# end foreach {spec specval} argdef_values
#cross-validate -choicealiases against the final merged choice set (goal G-040)
if {[tcl::dict::exists $spec_merged -choicealiases] && [tcl::dict::size [tcl::dict::get $spec_merged -choicealiases]]} {
set ca_allchoices [punk::args::system::Dict_getdef $spec_merged -choices {}]
foreach {_cagroup camembers} [punk::args::system::Dict_getdef $spec_merged -choicegroups {}] {
lappend ca_allchoices {*}$camembers
}
tcl::dict::for {ca_alias ca_canonical} [tcl::dict::get $spec_merged -choicealiases] {
if {$ca_canonical ni $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' maps alias '$ca_alias' to '$ca_canonical' which is not in -choices/-choicegroups @id:$DEF_definition_id"
}
if {$ca_alias in $ca_allchoices} {
error "punk::args::resolve - -choicealiases for argument '$argname' alias '$ca_alias' collides with a defined choice @id:$DEF_definition_id"
}
}
}
if {$is_opt} {
#tcl::dict::set FDICT ARG_CHECKS $argname {*}{
# } [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
tcl::dict::set upd_ARG_CHECKS $argname {*}{
} [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
if {$argname eq "--"} {
#force -type none - in case no -type was specified and @opts -type is some other default such as string
tcl::dict::set spec_merged -type none
}
if {[tcl::dict::get $spec_merged -type] eq "none"} {
#todo - detach and reattach
dict set FDICT OPT_SOLOS [list {*}[dict get $FDICT OPT_SOLOS] $argname]
}
if {[tcl::dict::get $spec_merged -mash]} {
#The value for -mash might be true only due to a default from @opts - in which case we need to check the argname for validity of -mash as described above and if not valid, set -mash false in the ARG_INFO for this argname
if {$argname eq "--"} {
#force -mash false - in case no -mash was specified on the flag itself and @opts -mash is true
tcl::dict::set spec_merged -mash false
} else {
set has_single_letter_flag 0
foreach alias $optaliases {
if {[string length $alias] == 2 && [string match -* $alias]} {
set has_single_letter_flag 1
break
}
}
if {!$has_single_letter_flag} {
#force -mash false in ARG_INFO for this argname - in case no -mash was specified and @opts -mash is true by default but argname doesn't contain any single-letter flags
tcl::dict::set spec_merged -mash false
}
}
#re-test state of -mash after any adjustments based on argname validity and defaults
if {[tcl::dict::get $spec_merged -mash]} {
#we add the whole argname with all aliases to the OPT_MASHES list - this is used during parsing to check if any of the aliases for a given flag are mashable
dict set FDICT OPT_MASHES [list {*}[dict get $FDICT OPT_MASHES] $argname]
}
}
} else {
#tcl::dict::set FDICT ARG_CHECKS $argname {*}{
# } [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
tcl::dict::set upd_ARG_CHECKS $argname {*}{
} [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize
}
tcl::dict::set FDICT ARG_INFO $argname $spec_merged
#review existence of -default overriding -optional
#if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} {}
if {![tcl::dict::get $spec_merged -optional]} {
if {$is_opt} {
#upd_OPT_REQUIRED
set req_name [tcl::dict::get $spec_merged -parsekey]
if {$req_name eq ""} {
set req_name [string trimright [lindex [split $argname |] end] =]
}
if {$req_name ni $upd_OPT_REQUIRED} {
lappend upd_OPT_REQUIRED $req_name
}
} else {
if {[dict get $FDICT argspace] eq "leaders"} {
if {[dict exists $spec_merged -parsekey]} {
#if parsekey exists, we use that in the required list instead of argname, as that's what the parser will be looking for when it checks for required args
set req_name [dict get $spec_merged -parsekey]
} else {
set req_name $argname
}
if {$req_name ni $upd_LEADER_REQUIRED} {
lappend upd_LEADER_REQUIRED $argname
}
} else {
#review
if {[dict exists $spec_merged -parsekey]} {
#if parsekey exists, we use that in the required list instead of argname, as that's what the parser will be looking for when it checks for required args
set req_name [dict get $spec_merged -parsekey]
} else {
set req_name $argname
}
if {$req_name ni $upd_VAL_REQUIRED} {
lappend upd_VAL_REQUIRED $req_name
}
}
}
}
if {[tcl::dict::exists $spec_merged -default]} {
if {$is_opt} {
#JJJ
set parsekey [dict get $FDICT ARG_INFO $argname -default]
if {$parsekey eq ""} {
set parsekey $argname
}
dict set upd_OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default]
#tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default]
} else {
if {[dict get $FDICT argspace] eq "leaders"} {
dict set upd_LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default]
#tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default]
} else {
dict set upd_VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default]
#tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default]
}
}
}
#restore possibly updated versions of keys after processing this argdef
dict set FDICT OPT_REQUIRED $upd_OPT_REQUIRED
dict set FDICT VAL_REQUIRED $upd_VAL_REQUIRED
dict set FDICT LEADER_REQUIRED $upd_LEADER_REQUIRED
dict set FDICT OPT_DEFAULTS $upd_OPT_DEFAULTS
dict set FDICT VAL_DEFAULTS $upd_VAL_DEFAULTS
dict set FDICT LEADER_DEFAULTS $upd_LEADER_DEFAULTS
dict set FDICT ARG_CHECKS $upd_ARG_CHECKS
dict set F $fid $FDICT ;#reattach updated form dict to main F dict after processing this argdef
} ;# end foreach fid record_form_ids
} ;# end foreach rec $records
#if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} {
# variable id_counter
# set DEF_definition_id "autoid_[incr id_counter]"
#}
#now cycle through ALL forms not just form_ids_active (record_form_ids)
dict for {fid FDICT} $F {
dict set F $fid {} ;#detach
#set mashargs [dict get $F $fid OPT_MASHES]
set mashargs [dict get $FDICT OPT_MASHES]
if {[llength $mashargs]} {
#precalculate OPT_ALL_MASH_LETTERS
set all_mash_letters [list]
foreach fullopt $mashargs {
foreach flagpart [split $fullopt |] {
if {[string length $flagpart] == 2 && [string match -* $flagpart]} {
lappend all_mash_letters [string index $flagpart 1]
}
}
}
dict set FDICT OPT_ALL_MASH_LETTERS $all_mash_letters
}
if {[tcl::dict::get $FDICT OPT_MAX] eq ""} {
if {[llength [tcl::dict::get $FDICT OPT_NAMES]] == 0 && ![tcl::dict::get $FDICT OPT_ANY]} {
tcl::dict::set FDICT OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily
#review - when using resolved_def to create a definiation based on another - OPT_MAX may need to be overridden - a bit ugly?
}
}
# REVIEW
#no values specified - we can allow last leader to be multiple
foreach leadername [lrange [tcl::dict::get $FDICT LEADER_NAMES] 0 end-1] {
if {[tcl::dict::get $FDICT ARG_INFO $leadername -multiple]} {
error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id"
}
}
#todo - disallow any -multiple == true entries if any leaders have -multiple == true?
#(creates parsing ambiguity)
#ambiguity could be resolved if at least one required option/flag eg --
#ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type
#(overcomplex? todo see if any core/tcllib commands work like that)
#only allow a single entry within VAL_NAMES to have -multiple == true
#example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir
set val_multiples 0
foreach valname [lrange [tcl::dict::get $FDICT VAL_NAMES] 0 end-1] {
if {[tcl::dict::get $FDICT ARG_INFO $valname -multiple]} {
if {$val_multiples > 0} {
error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id"
}
incr val_multiples
}
}
#todo - document that ambiguities in API are likely if both @leaders and @values used
#todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options)
dict set FDICT LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $FDICT LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize
dict set FDICT OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $FDICT OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize
dict set FDICT VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $FDICT VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize
dict set F $fid $FDICT ;#reattach updated form dict to main F dict after processing this form
}
#todo - precalculate a set of 'arity' entries for each form
#We want a structure for the arg parser to get easy access and make a fast decision on which form applies
#eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ?
#1) after ms (1 1)
#2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...?
#3) after cancel id (2 2)
#4) after cancel script ?script...? (2 -1)
#5) after idle script ?script...? (1 -1)
#6) after info ?id? (1 2)
#for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple)
#in the above case we have no unique total_arity
#we would also want to consider values when selecting
#e.g given the invalid command "after cancel"
# we should be selecting forms 3 & 4 rather than the exact arity match given by 1.
set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands
#todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use
#even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form
#e.g commandline completion could show list of synopsis entries to select from
set form_info [dict create]
dict for {fid fdict} $F {
dict set form_info $fid {}
dict for {optk optv} $fdict {
if {[string match -* $optk]} {
dict set form_info $fid $optk $optv
}
}
}
set argdata_dict [tcl::dict::create {*}{
} id $DEF_definition_id {*}{
} cmd_info $cmd_info {*}{
} doc_info $doc_info {*}{
} package_info $package_info {*}{
} seealso_info $seealso_info {*}{
} instance_info $instance_info {*}{
} keywords_info $keywords_info {*}{
} examples_info $examples_info {*}{
} id_info $id_info {*}{
} FORMS $F {*}{
} form_names [dict keys $F] {*}{
} form_info $form_info {*}[
# G-046: DISPLAY_DEFERRED maps inert display tokens -> {source <${...}-content> defspace <ns> dynamic <bool>}
# for display-only field content whose expansion was deferred out of parsing.
# Expanded on demand by private::expand_display_fields (empty when nothing deferred).
] DISPLAY_DEFERRED $deferred_display {*}{
}
]
#REVIEW
tcl::dict::set rawdef_cache_argdata $cache_key $argdata_dict
if {$is_dynamic} {
#also cache resolved version
tcl::dict::set rawdef_cache_argdata [list $optionspecs] $argdata_dict
}
#tcl::dict::set id_cache_rawdef $DEF_definition_id $args
#puts "xxx:$result"
return $argdata_dict
}
#no discernable difference in performance.
# proc jtest1 {} {
# set FDICT [dict create g GG h HH i II j JJ k KK l LL m MM n NN o OO p PP q QQ r RR s SS t TT u UU v VV w WW x XX y YY z ZZ]
# dict set FDICT LEADER_CHECKS_DEFAULTS [dict create -validate_ansistripped 0 -allow_ansi 1 a A b B c C d D e E f F -type any -default blah -multiple 1 -strip_ansi 1]
#
# dict set FDICT LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $FDICT LEADER_CHECKS_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize
# }
# proc jtest2 {} {
# set FDICT [dict create g GG h HH i II j JJ k KK l LL m MM n NN o OO p PP q QQ r RR s SS t TT u UU v VV w WW x XX y YY z ZZ]
# dict set FDICT LEADER_CHECKS_DEFAULTS [dict create -validate_ansistripped 0 -allow_ansi 1 a A b B c C d D e E f F -type any -default blah -multiple 1 -strip_ansi 1]
#
# set upd_LEADER_CHECKS_DEFAULTS [dict get $FDICT LEADER_CHECKS_DEFAULTS]
# dict set FDICT LEADER_CHECKS_DEFAULTS {} ;#detach
#
# #dict set FDICT LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $FDICT LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize
# set upd_LEADER_CHECKS_DEFAULTS [tcl::dict::remove $upd_LEADER_CHECKS_DEFAULTS -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize
#
# dict set FDICT LEADER_CHECKS_DEFAULTS $upd_LEADER_CHECKS_DEFAULTS; #reattach
# }
# proc jtest3 {} {
# set FDICT [dict create g GG h HH i II j JJ k KK l LL m MM n NN o OO p PP q QQ r RR s SS t TT u UU v VV w WW x XX y YY z ZZ]
# dict set FDICT LEADER_CHECKS_DEFAULTS [dict create -validate_ansistripped 0 -allow_ansi 1 a A b B c C d D e E f F -type any -default blah -multiple 1 -strip_ansi 1]
#
# set upd_LEADER_CHECKS_DEFAULTS [dict get $FDICT LEADER_CHECKS_DEFAULTS]
# dict set FDICT LEADER_CHECKS_DEFAULTS {} ;#detach
#
# #dict set FDICT LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $FDICT LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize
# set upd_LEADER_CHECKS_DEFAULTS [tcl::dict::remove $upd_LEADER_CHECKS_DEFAULTS[set upd_LEADER_CHECKS_DEFAULTS {}] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize
#
# dict set FDICT LEADER_CHECKS_DEFAULTS $upd_LEADER_CHECKS_DEFAULTS; #reattach
# }
#return raw definition list as created with 'define'
# - possibly with unresolved dynamic parts
lappend PUNKARGS [list {
@id -id ::punk::args::raw_def
@cmd -name punk::args::raw_def\
-summary\
"Return the raw (unresolved) definition list for an id."\
-help\
"Returns the raw definition list (list of definition blocks) as
originally supplied for the id.
The id is first resolved via punk::args::real_id, so aliases and
definitions in not-yet-scanned registered namespaces are found.
Returns an empty string if the id can't be resolved."
@values -min 1 -max 1
id -type string -help\
"id or id alias of the definition"
}]
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 @examples @formdisplay @seealso @instance @leaders @opts @values leaders opts values}
variable resolved_def_TYPE_CHOICEGROUPS {
directives {@id @package @cmd @ref @doc @examples @formdisplay @seealso @instance}
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 The members of each override sub dictionary are
usually options beginning with a dash. The key 'name' can be used to
override the name of the leader/option/value itself.
e.g
punk::args::resolved_def -types values -override {version {name version1 -optional 0}} (shared)::package version
"
@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 -cache 1 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]
switch -exact -- $a {
-type - -types {
incr i
dict set opts -types [lindex $args $i]
}
default {
if {[string match -* $a]} {
incr i
dict set opts $a [lindex $args $i]
} else {
set id [lindex $args $i]
set patterns [lrange $args $i+1 end]
break
}
}
}
if {$i == [llength $args]-1} {
punk::args::parse $args withid ::punk::args::resolved_def
return
}
}
if {![llength $patterns]} {
set patterns [list *]
}
dict for {k v} $opts {
#set fullk [tcl::prefix::match -error "" {-return -form -types -antiglobs -override} $k]
switch -- $k {
-return - -form - -types - -antiglobs - -override {}
default {
punk::args::parse $args withid ::punk::args::resolved_def
return
}
}
}
set typelist [dict get $opts -types]
if {[llength $typelist] == 0} {
set typelist {*}
}
foreach type $typelist {
if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} {
punk::args::parse $args withid ::punk::args::resolved_def
return
}
}
variable id_cache_rawdef
set realid [real_id $id]
if {$realid eq ""} {
return
}
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
#G-046: resolved_def re-emits definition text from the spec - deferred display
#tokens must never leak into consumer definitions, so expand first.
set specdict [private::expand_display_fields $specdict]
set opt_form [dict get $opts -form]
if {[string is integer -strict $opt_form]} {
set formname [lindex [dict get $specdict form_names] $opt_form]
} else {
set formname $opt_form
}
set opt_override [dict get $opts -override]
set opt_return [dict get $opts -return]
#set arg_info [dict get $specdict ARG_INFO]
set arg_info [dict get $specdict FORMS $formname ARG_INFO]
set argtypes [dict create leaders leader opts option values value]
set opt_antiglobs [dict get $opts -antiglobs]
set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *]
set suppressed_directives [list]
set suppressed_args [list]
foreach ag $opt_antiglobs {
foreach d $directives {
if {[string match $ag $d]} {
lappend suppressed_directives $d
}
}
foreach argname [dict keys $arg_info] {
if {[string match $ag $argname]} {
lappend suppressed_args $argname
}
}
}
set suppressed_directives [lsort -unique $suppressed_directives]
set suppressed_args [lsort -unique $suppressed_args]
set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives]
set globbed [list]
foreach pat $patterns {
set matches [dict keys $arg_info $pat]
lappend globbed {*}$matches
}
set globbed [lsort -unique $globbed]
#maintain order of original arg_info keys in globbed results
set ordered_globbed [list]
foreach a [dict keys $arg_info] {
if {$a ni $ordered_globbed && $a in $globbed} {
lappend ordered_globbed $a
}
}
set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args]
set result ""
set resultdict [dict create]
foreach type $typelist {
switch -exact -- $type {
* {
if {"@id" in $included_directives} {
if {[dict exists $opt_override @id]} {
append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]"
dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]
} else {
append result \n "@id -id [dict get $specdict id]"
dict set resultdict @id [list -id [dict get $specdict id]]
}
}
foreach directive {@package @cmd @doc @examples @seealso @instance} {
set dshort [string range $directive 1 end]
if {"$directive" in $included_directives} {
if {[dict exists $opt_override $directive]} {
append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]"
dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]
} else {
append result \n "$directive [dict get $specdict ${dshort}_info]"
dict set resultdict $directive [dict get $specdict ${dshort}_info]
}
}
}
#todo @formdisplay
#todo @ref ?
#output ordered by leader, option, value
foreach pseudodirective {leaders opts values} tp {leader option value} {
set directive "@$pseudodirective"
switch -- $directive {
@leaders {set defaults_key LEADERSPEC_DEFAULTS}
@opts {set defaults_key OPTSPEC_DEFAULTS}
@values {set defaults_key VALSPEC_DEFAULTS}
}
if {"$directive" in $included_directives} {
if {[dict exists $opt_override "$directive"]} {
append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]"
dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]
} else {
append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]"
dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key]
}
}
if {$pseudodirective in $included_directives} {
foreach m $included_args {
set argspec [dict get $arg_info $m]
if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} {
set overdict [dict get $opt_override $m]
append result \n "\"$m\" [dict merge $argspec $overdict]"
dict set resultdict $m [dict merge $argspec $overdict]
} 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 - @examples - @seealso - @instance {
if {"$type" in $included_directives} {
set tp [string range $type 1 end] ;# @package -> package
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict ${tp}_info]"
dict set resultdict $type [dict get $specdict ${tp}_info]
}
}
#todo @formdisplay
}
@leaders - @opts - @values {
#these are the active defaults for further arguments
if {"$type" in $included_directives} {
switch -- $type {
@leaders {set defaults_key LEADERSPEC_DEFAULTS}
@opts {set defaults_key OPTSPEC_DEFAULTS}
@values {set defaults_key VALSPEC_DEFAULTS}
}
if {[dict exists $opt_override $type]} {
append result \n "$type [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $type]]"
dict set resultdict $type [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $type]]
} else {
append result \n "$type [dict get $specdict FORMS $formname $defaults_key]"
dict set resultdict $type [dict get $specdict FORMS $formname $defaults_key]
}
}
}
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]} {
set overdict [dict get $opt_override $m]
if {[dict exists $opt_override $m name]} {
#special override for name of argument itself
#e.g
#punk::args::resolved_def -types values -override {version {name version1 -optional 1}} (shared)::package version
set newname [dict get $opt_override $m name]
dict unset overdict name
append result \n "\"$newname\" [dict merge $argspec $overdict]"
dict set resultdict $newname [dict merge $argspec $overdict]
} else {
append result \n "\"$m\" [dict merge $argspec $overdict]"
dict set resultdict $m [dict merge $argspec $overdict]
}
} else {
append result \n "\"$m\" $argspec"
dict set resultdict $m $argspec
}
}
}
}
}
default {
}
}
if {$opt_return eq "text"} {
return $result
} else {
return $resultdict
}
}
}
lappend PUNKARGS [list {
@id -id ::punk::args::resolved_def_values
@cmd -name punk::args::resolved_def_values\
-summary\
"Return textual definitions for the trailing values of a resolved definition."\
-help\
"Returns a text block of 'name <definitiondict>' lines for the
@values (trailing positional) arguments of the resolved definition,
optionally filtered by glob patterns on the value names.
See also punk::args::resolved_def for the full definition."
@values -min 1 -max 2
id -type string -help\
"id or id alias of the definition"
patternlist -type list -default * -optional 1 -help\
"List of glob patterns to match against value argument names"
}]
proc resolved_def_values {id {patternlist *}} {
variable id_cache_rawdef
set realid [real_id $id]
if {$realid ne ""} {
set deflist [tcl::dict::get $id_cache_rawdef $realid]
set specdict [resolve {*}$deflist]
set arg_info [dict get $specdict ARG_INFO]
set valnames [dict get $specdict VAL_NAMES]
set result ""
if {$patternlist eq "*"} {
foreach v $valnames {
set def [dict get $arg_info $v]
set def [dict remove $def -ARGTYPE]
append result \n "$v $def"
}
return $result
} else {
foreach pat $patternlist {
set matches [dict keys $arg_info $pat]
set matches [lsearch -all -inline -glob $valnames $pat]
foreach m $matches {
set def [dict get $arg_info $m]
set def [dict remove $def -ARGTYPE]
append result \n "$m $def"
}
}
return $result
}
}
}
#proc resolved_def_leaders ??
#proc resolved_def_opts ??
lappend PUNKARGS [list {
@id -id ::punk::args::get_spec
@cmd -name punk::args::get_spec\
-summary\
"Return the resolved internal specification dictionary for an id."\
-help\
"Retrieves the raw definition for the id (resolving aliases) and
returns the resolved internal specification dictionary as produced
by punk::args::resolve.
Returns an empty string if the id can't be resolved."
@values -min 1 -max 1
id -type string -help\
"id or id alias of the definition"
}]
proc get_spec {id} {
set deflist [raw_def $id]
if {$deflist eq ""} {
return
}
return [resolve {*}$deflist]
#if {[id_exists $id]} {
# return [resolve {*}[raw_def $id]]
#}
}
lappend PUNKARGS [list {
@id -id ::punk::args::is_dynamic
@cmd -name punk::args::is_dynamic\
-summary\
"Test whether the definition for an id is flagged as dynamic."\
-help\
"Returns a boolean indicating whether the definition contains an
@dynamic directive (or legacy leading '-dynamic 1' arguments).
Dynamic definitions are re-substituted (dollar variables and
bracketed commands within the text) in the defining namespace on
resolution rather than being resolved once and cached in final form."
@values -min 1 -max 1
id -type string -help\
"id or id alias of the definition"
}]
proc is_dynamic {id} {
variable id_cache_rawdef
variable rawdef_cache_about
set deflist [raw_def $id]
if {[dict exists $rawdef_cache_about $deflist -dynamic]} {
return [dict get $rawdef_cache_about $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 first 3 blocks - or assign auto
#review - @dynamic block where -id not explicitly set? - disallow?
lappend PUNKARGS [list {
@id -id ::punk::args::rawdef_id
@cmd -name punk::args::rawdef_id\
-summary\
"Determine the id for a raw definition list."\
-help\
"Extracts the id from the @id -id <value> line of a raw definition list.
The @id line must appear within the first 4 lines of one of the first
3 definition blocks. If no @id line is present (or its -id value is
'auto') an automatic id of the form autoid_<n> is generated.
A malformed @id line (found but no retrievable -id value) raises an error.
The -id value undergoes tstr substitution in the caller's context at
the given level."
@values -min 1 -max 2
rawdef -type list -help\
"Raw definition list (list of definition blocks)"
lvl -type integer -default 1 -optional 1 -help\
"uplevel offset at which to perform tstr substitution of the @id line"
}]
proc rawdef_id {rawdef {lvl 1}} {
set id ""
set found_id_line 0
foreach d [lrange $rawdef 0 2] {
foreach ln [lrange [split $d \n] 0 4] {
if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} {
if {$firstword eq "@id"} {
set found_id_line 1
#review - uplevel 2 would be a call from punk::args::define ??
set rest [uplevel $lvl [list punk::args::lib::tstr -allowcommands $rest]]
if {[llength $rest] %2 == 0 && [dict exists $rest -id]} {
set id [dict get $rest -id]
}
break
}
}
}
if {$found_id_line} {
break
}
}
if {$id eq "" && $found_id_line} {
#Looked like an @id - but presumable the rest of the line was malformed.
#we won't produce an autoid for such a definition.
set first3blocks ""
foreach b [lrange $rawdef 0 2] {
append first3blocks $b\n
}
error "punk::args::rawdef_id found an @id line in the first 4 lines of one of the 1st 3 blocks - but failed to retrieve a value for it.\nraw_def 1st 3 blocks:\n$first3blocks"
}
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
lappend PUNKARGS [list {
@id -id ::punk::args::rawdef_is_dynamic
@cmd -name punk::args::rawdef_is_dynamic\
-summary\
"Test whether a raw definition list is flagged as dynamic."\
-help\
"Returns a boolean indicating whether the raw definition list contains
a block beginning with the @dynamic directive (or uses the legacy
leading '-dynamic 1' argument form).
See also punk::args::is_dynamic which tests by id."
@values -min 1 -max 1
rawdef -type list -help\
"Raw definition list (list of definition blocks)"
}]
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 first_rawdef_word]} {
if {$first_rawdef_word 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
lappend PUNKARGS [list {
@id -id ::punk::args::id_exists
@cmd -name punk::args::id_exists\
-summary\
"Test whether an id or id alias is already known."\
-help\
"Returns a boolean indicating whether the supplied value is a known
definition id or id alias.
Only direct ids and aliases are tested - (autodef)<id> entries are not
automatically checked, and no update_definitions scan is triggered
(compare punk::args::real_id)."
@values -min 1 -max 1
id -type string -help\
"id or id alias to test"
}]
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
}
lappend PUNKARGS [list {
@id -id ::punk::args::idaliases
@cmd -name punk::args::idaliases\
-summary\
"Display the current id alias dictionary."\
-help\
"Returns a display (punk::lib::showdict) of the alias -> id mapping
for all id aliases created with punk::args::set_idalias."
@values -min 0 -max 0
}]
proc idaliases {} {
variable aliases
punk::lib::showdict $aliases
}
lappend PUNKARGS [list {
@id -id ::punk::args::set_idalias
@cmd -name punk::args::set_idalias\
-summary\
"Create or update an alias for a definition id."\
-help\
"Creates (or overwrites) an alias that can be used in place of the
target id in functions such as punk::args::parse (withid), raw_def,
get_spec and usage.
The target id need not exist at the time the alias is created."
@values -min 2 -max 2
alias -type string -help\
"alias name"
id -type string -help\
"target definition id"
}]
proc set_idalias {alias id} {
variable aliases
dict set aliases $alias $id
}
lappend PUNKARGS [list {
@id -id ::punk::args::unset_idalias
@cmd -name punk::args::unset_idalias\
-summary\
"Remove an id alias."\
-help\
"Removes an alias created with punk::args::set_idalias.
A no-op if the alias doesn't exist."
@values -min 1 -max 1
alias -type string -help\
"alias name to remove"
}]
proc unset_idalias {alias} {
variable aliases
dict unset aliases $alias
}
lappend PUNKARGS [list {
@id -id ::punk::args::get_idalias
@cmd -name punk::args::get_idalias\
-summary\
"Return the target id for an alias."\
-help\
"Returns the id that the alias points to,
or an empty string if the alias doesn't exist."
@values -min 1 -max 1
alias -type string -help\
"alias name to look up"
}]
proc get_idalias {alias} {
variable aliases
if {[dict exists $aliases $alias]} {
return [tcl::dict::get $aliases $alias]
}
}
lappend PUNKARGS [list {
@id -id ::punk::args::id_query
@cmd -name punk::args::id_query\
-summary\
"Developer report of cache state for a definition id."\
-help\
"Returns a text report showing the raw definition, id info
(dynamic flag, defining namespace) and argdata cache entries
for the id - including a warning if the id is unexpectedly
present under multiple rawdef keys.
Intended for interactive/debug use.
Returns an empty string if the id isn't directly present
(aliases are not followed - see punk::args::real_id)."
@values -min 1 -max 1
id -type string -help\
"definition id to report on"
}]
proc id_query {id} {
variable id_cache_rawdef
variable rawdef_cache_about
if {[dict exists $id_cache_rawdef $id]} {
set sep [string repeat - 40]
set rawdef [dict get $id_cache_rawdef $id]
if {[dict exists $rawdef_cache_about $rawdef]} {
set idinfo [dict get $rawdef_cache_about $rawdef]
} else {
set idinfo ""
}
set result "raw definition:"
append result \n $sep
append result \n $rawdef
append result \n $sep
append result \n "id info:"
append result \n $idinfo
append result \n $sep
variable rawdef_cache_argdata
#lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?)
#check for and report if id is present multiple times
set argdata_records [list]
dict for {k v} $rawdef_cache_argdata {
if {[dict get $v id] eq $id} {
if {$k eq $rawdef} {
lappend argdata_records [list 1 $k $v]
} else {
lappend argdata_records [list 0 $k $v]
}
}
}
append result \n "argdata cache:"
if {![llength $argdata_records]} {
append result \n "(not present)"
} else {
append result \n "present [llength $argdata_records] time(s)"
foreach r $argdata_records {
lassign $r match k v
if {$match} {
append result \n " - present with same rawdef key"
} else {
append result \n " - present with different rawdef key"
append result \n " [punk::lib::indent $k { }]"
}
}
if {[llength $argdata_records] > 1} {
append result \n "*more than one record was not expected - review*"
}
}
append result \n $sep
return $result
}
}
lappend PUNKARGS [list {
@id -id ::punk::args::real_id
@cmd -name punk::args::real_id\
-summary\
"Resolve an id or alias to the actual id under which a definition is stored."\
-help\
"Resolves aliases and returns the id under which the definition is
actually stored - which may be the supplied id itself, the alias
target, or an (autodef)<id> entry created by the introspection
facilities.
If the id isn't found, punk::args::update_definitions is called for
the id's namespace qualifiers so that definitions in newly loaded
packages are discovered.
Returns an empty string if no definition can be found."
@values -min 1 -max 1
id -type string -help\
"id or id alias to resolve"
}]
proc real_id {id} {
variable id_cache_rawdef
variable aliases
if {[tcl::dict::exists $aliases $id]} {
set id [tcl::dict::get $aliases $id]
}
if {[tcl::dict::exists $id_cache_rawdef $id]} {
return $id
} else {
set check_updates [list [namespace qualifiers $id]]
#puts stderr "---->real_id '$id' update_definitions $check_updates"
if {![llength [update_definitions $check_updates]]} {
#nothing new loaded
if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} {
return (autodef)$id
}
return ""
} else {
if {[tcl::dict::exists $aliases $id]} {
set id [tcl::dict::get $aliases $id]
}
if {[tcl::dict::exists $id_cache_rawdef $id]} {
return $id
}
if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} {
return (autodef)$id
}
return ""
}
}
}
lappend PUNKARGS [list {
@id -id ::punk::args::status
@cmd -name punk::args::status\
-summary\
"Report scan/load status of registered definition namespaces."\
-help\
"Returns a table of namespaces registered in
punk::args::register::NAMESPACES showing, for each, how many ids were
found when scanned, how many definitions have been loaded, and the
time taken (microseconds) for the scan/load passes.
Definitions are scanned and loaded lazily - a blank row indicates a
package whose definitions haven't been needed yet."
@values -min 0 -max 0
}]
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
}
lappend PUNKARGS [list {
@id -id ::punk::args::update_definitions
@cmd -name punk::args::update_definitions\
-summary\
"Update internal caches with new definitions from packages that have been loaded since the last scan."\
-help\
"Scans for new definitions in the specified namespaces and updates internal caches.
This is called automatically by punk::args::real_id when an id is not found -
to ensure that any definitions in newly loaded packages are available for retrieval.
It can also be called manually to pre-load definitions from specific namespaces
- e.g to prepare for a series of calls to punk::args::real_id where the namespace origin of the ids is"
@values -min 1
nslist -type list -help\
"list of namespaces to update definitions for.
If a package namespace is included that hasn't been scanned yet,
it will be scanned as part of this call. If the list contains the single element '*',
all registered namespaces will be updated.
(scanned if not already scanned, and any new loaded packages will be included)."
}]
#scanned_packages (list)
#namespace_docpackages (dict)
proc update_definitions {{nslist *}} {
#puts "----> update_definitions '$nslist'"
if {[set gposn [lsearch $nslist {}]] >= 0} {
lset nslist $gposn ::
}
upvar ::punk::args::register::NAMESPACES registered ;#list
upvar ::punk::args::register::loaded_packages loaded_packages ;#list
upvar ::punk::args::register::loaded_info loaded_info ;#dict
upvar ::punk::args::register::scanned_packages scanned_packages ;#list
upvar ::punk::args::register::scanned_info scanned_info ;#dict
upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict
#puts stderr "-->update_definitions '$nslist'"
#needs to run quickly - especially when no package namespaces to be scanned for argdefs
#e.g - gets called for each subcommand of an ensemble (could be many)
# It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command.
#we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below.
# -- --- --- --- --- ---
# common-case fast-path
if {[llength $loaded_packages] == [llength $registered]} {
#the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do.
#assert - if all are registered - then all have been scanned
return {}
}
# -- --- --- --- --- ---
set unscanned [punk::args::system::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]
set lvl 1 ;#level at which tstr substitution occurs in @id line
set id [namespace eval $pkgns [list punk::args::rawdef_id $definitionlist $lvl]]
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 [punk::args::system::punklib_ldiff $registered $loaded_packages]
} else {
set needed [list]
foreach pkgns $nslist {
if {[string match (autodef)* $pkgns]} {
set pkgns [string range $pkgns 9 end]
}
if {![string match ::* $pkgns]} {
puts stderr "warning: update_definitions received unqualified ns: $pkgns"
set pkgns ::$pkgns
}
if {$pkgns in $registered && $pkgns ni $loaded_packages} {
lappend needed $pkgns
}
#argdoc sub namespace is a standard place to put defs that match the namespace below
#(generally the PUNKARGS in a namespace should apply to own ns)
set docns ${pkgns}::argdoc
if {[namespace exists $docns]} {
if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} {
lappend needed $docns
}
}
if {[dict exists $namespace_docpackages $pkgns]} {
#this namespace has other argdef sources
foreach docns [dict get $namespace_docpackages $pkgns] {
if {$docns ni $loaded_packages} {
lappend needed $docns
}
}
}
}
}
set newloaded [list]
foreach pkgns $needed {
#puts stderr "update_definitions Loading: $pkgns"
set ts_start [clock microseconds]
set def_count 0
if {![catch {
if {[info exists ${pkgns}::PUNKARGS]} {
set docns ${pkgns}::argdoc
if {[namespace exists $docns]} {
namespace eval ${pkgns}::argdoc {
set epath [namespace path]
set pkgns [namespace parent]
if {$pkgns ni $epath} {
namespace path [list {*}$epath $pkgns] ;#add to tail
}
}
set evalns $docns
} else {
set evalns $pkgns
}
foreach definitionlist [set ${pkgns}::PUNKARGS] {
namespace eval $evalns [list punk::args::define {*}$definitionlist]
incr def_count
}
}
#process list of 2-element lists
if {[info exists ${pkgns}::PUNKARGS_aliases]} {
foreach adef [set ${pkgns}::PUNKARGS_aliases] {
punk::args::set_idalias {*}$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 depth [info level]
set maxd [expr {min($depth,4)}]
set call_level [expr {-1 * $maxd}]
#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]"
set maxloop 10 ;#failsafe
while {$maxloop > -1 && [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
}
}
incr maxloop -1
}
set caller [regexp -inline {\S+} $cmdinfo]
if {$caller eq "namespace"} {
# review - message?
set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace"
}
return $cmdinfo
}
# --------------------------------------
#developer diagnostics - test of Get_caller (unexported - leading underscores exclude from export pattern)
lappend PUNKARGS [list {
@id -id ::punk::args::__test1
@values -min 0 -max 0
}]
proc __test_get_dict {args} {
punk::args::get_dict [punk::args::raw_def ::punk::args::__test1] $args
}
proc __test_get_by_id {args} {
punk::args::get_by_id ::punk::args::__test1 $args
}
#supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct.
proc __test_callers {args} {
if {![llength $args]} {
puts "these test functions accept no arguments"
puts "Call with arg(s) to compare error output"
}
if {[catch {__test_get_dict {*}$args} errM]} {
puts $errM
}
puts "------------"
if {[catch {__test_get_by_id {*}$args} errM]} {
puts $errM
}
return done
}
# --------------------------------------
set map ""
lappend PUNKARGS [list [string map $map {
@id -id ::punk::args::arg_error
@cmd -name punk::args::arg_error -help\
"Generates a table (by default) of usage information for a command.
A trie system is used to create highlighted prefixes for command
switches and for subcommands or argument/switch values that accept
a defined set of choices. These prefixes match the mechanism used
to validate arguments (based on tcl::prefix::match).
This function is called during the argument parsing process
(if the definition is not only being used for documentation)
It is also called by punk::args::usage which is in turn
called by the punk::ns introspection facilities which creates
on the fly definitions for some commands such as ensembles and
oo objects where a manually defined one isn't present.
"
@leaders -min 2 -max 2
msg -type string -help\
"Error message to display immediately prior to usage table.
May be empty string to just display usage.
"
spec_dict -type dict -help\
"Dictionary of argument specifications.
This is the internal format parsed from
the textual definition. It contains the data
organised/optimised to allow the final arg
parser/validator to make decisions.
"
@opts
-badarg -type string -help\
"name of an argument to highlight"
-parsedargs -type dict -help\
"Result of successful punk::args::parse.
Together with -badarg this is converted internally to the
parse-status structure the renderers consume (received argument
rows get the goodarg style, choice words matching an argument's
value-in-effect are highlighted)."
-parsestatus -type dict -help\
"Parse-status structure as returned by punk::args::parse_status.
The renderers derive goodarg/badarg row marking and choice
value-in-effect highlighting from it. Takes precedence over
-badarg/-parsedargs. Should be built for the same form the
display renders (see -form)."
-aserror -type boolean -help\
"If true, the usage table is raised as an error message,
otherwise it is returned as a value."
-return -choices {string table tableobject} -choicelabels {
string "no table layout"
tableobject "table object cmd"
table "full table layout"
}
-scheme -default error -choices {nocolour info error}
-form -default 0 -help\
"Ordinal index or name of command form"
}] ]
variable arg_error_CLR
array set arg_error_CLR {}
variable arg_error_CLR_nocolour
array set arg_error_CLR_nocolour {}
variable arg_error_CLR_info
array set arg_error_CLR_info {}
variable arg_error_CLR_error
array set arg_error_CLR_error {}
proc private::argerror_load_colours {{forcereload 0}} {
#colour state arrays live in the parent punk::args namespace (shared with arg_error)
upvar #0 ::punk::args::arg_error_CLR arg_error_CLR
#todo - option for reload/retry?
if {!$forcereload && [array size arg_error_CLR] > 0} {
return
}
if {[catch {package require punk::ansi} errMsg]} {
puts stderr "punk::args FAILED to load punk::ansi\n$errMsg"
proc ::punk::args::a {args} {}
proc ::punk::args::a+ {args} {}
} else {
namespace eval ::punk::args {
namespace import ::punk::ansi::a ::punk::ansi::a+
}
}
#array set arg_error_CLR {}
set arg_error_CLR(testsinglecolour) [a+ yellow] ;#A single SGR colour to test current colour on|off state (empty string vs some result - used to determine if forcereload required)
set arg_error_CLR(errormsg) [a+ brightred]
set arg_error_CLR(title) ""
set arg_error_CLR(check) [a+ brightgreen]
set arg_error_CLR(solo) [a+ brightcyan]
set arg_error_CLR(choiceprefix) [a+ underline]
set arg_error_CLR(badarg) [a+ brightred]
set arg_error_CLR(goodarg) [a+ green strike]
set arg_error_CLR(goodchoice) [a+ reverse]
set arg_error_CLR(linebase_header) [a+ white]
set arg_error_CLR(linebase) [a+ white]
set arg_error_CLR(cmdname) [a+ brightwhite]
set arg_error_CLR(groupname) [a+ bold]
set arg_error_CLR(ansiborder) [a+ bold]
set arg_error_CLR(ansibase_header) [a+ bold]
set arg_error_CLR(ansibase_body) [a+ white]
set arg_error_CLR(parsekey_hint) [a+ term-grey46]
upvar #0 ::punk::args::arg_error_CLR_nocolour arg_error_CLR_nocolour
#array set arg_error_CLR_nocolour {}
set arg_error_CLR_nocolour(errormsg) [a+ bold]
set arg_error_CLR_nocolour(title) [a+ bold]
set arg_error_CLR_nocolour(check) ""
set arg_error_CLR_nocolour(solo) ""
set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment
set arg_error_CLR_nocolour(goodarg) [a+ strike]
set arg_error_CLR_nocolour(linebase_header) ""
set arg_error_CLR_nocolour(linebase) ""
set arg_error_CLR_nocolour(cmdname) [a+ bold]
set arg_error_CLR_nocolour(groupname) [a+ bold]
set arg_error_CLR_nocolour(ansiborder) [a+ bold]
set arg_error_CLR_nocolour(ansibase_header) [a+ bold]
set arg_error_CLR_nocolour(ansibase_body) ""
set arg_error_CLR_nocolour(parsekey_hint) ""
upvar #0 ::punk::args::arg_error_CLR_info arg_error_CLR_info
#array set arg_error_CLR_info {}
set arg_error_CLR_info(errormsg) [a+ brightred bold]
set arg_error_CLR_info(title) [a+ brightyellow bold]
set arg_error_CLR_info(check) [a+ brightgreen bold]
set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold]
set arg_error_CLR_info(groupname) [a+ cyan bold]
#set arg_error_CLR_info(ansiborder) [a+ brightcyan bold]
set arg_error_CLR_info(ansiborder) [a+ term-grey23 bold]
set arg_error_CLR_info(ansibase_header) [a+ cyan]
set arg_error_CLR_info(ansibase_body) [a+ white]
upvar #0 ::punk::args::arg_error_CLR_error arg_error_CLR_error
#array set arg_error_CLR_error {}
set arg_error_CLR_error(errormsg) [a+ brightred bold]
set arg_error_CLR_error(title) [a+ brightcyan bold]
set arg_error_CLR_error(check) [a+ brightgreen bold]
set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold]
set arg_error_CLR_error(groupname) [a+ cyan bold]
set arg_error_CLR_error(ansiborder) [a+ brightyellow bold]
set arg_error_CLR_error(ansibase_header) [a+ yellow]
set arg_error_CLR_error(ansibase_body) [a+ white]
}
#bas ic recursion blocker
variable arg_error_isrunning 0
proc arg_error {msg spec_dict args} {
#G-046: specs may arrive with display-only field content deferred (parse specs
#travel in error options as -argspecs). Expand for display before rendering.
if {[tcl::dict::exists $spec_dict DISPLAY_DEFERRED] && [tcl::dict::size [tcl::dict::get $spec_dict DISPLAY_DEFERRED]]} {
set spec_dict [private::expand_display_fields $spec_dict]
}
#todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path.
#accept an option here so that we can still use full output for usage requests.
#This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args
#Development/experimentation may be done with full table-based error reporting - but for production release it
#may be desirable to reduce overhead on catches.
#consider per-namespace or namespace-tree configurability.
#In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due
#to resource availability etc - so the slower error generation time may not always be a problem.
#Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling
#code which has no use for the enhanced error info.
#The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user.
#consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system
#todo
#investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error
#asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail)
#todo - document unnamed leaders and unnamed values where -min and/or -max specified
#e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2}
#only |?-x?|string|... is shown in the output table.
#should be something like:
# |arg |
# |?-x? |
# |arg |
# |?arg...?|
# Where/how to specify counts?
#also..
# use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y?
#
#limit colours to standard 16 so that themes can apply to help output
variable arg_error_isrunning
if {$arg_error_isrunning} {
set arg_error_isrunning 0
error "arg_error already running - error in arg_error?\n triggering errmsg: $msg"
}
#set arg_error_CLR(testsinglecolour) [a+ brightred]
variable arg_error_CLR
set forcereload 0 ;#no need for forcereload to be true for initial run - empty array will trigger initial load
if {[info exists arg_error_CLR(testsinglecolour)]} {
set terminal_colour_is_on [expr {[string length [a+ yellow]]}]
set error_colour_is_on [expr {[string length $arg_error_CLR(testsinglecolour)]}]
if {$terminal_colour_is_on ^ $error_colour_is_on} {
#results differ
set forcereload 1
}
}
private::argerror_load_colours $forcereload
#per-render colour resolution: CLR is proc-local, seeded from the shared base array;
#a scheme's overrides are merged into this local copy only. (Merging into the shared
#arg_error_CLR leaked scheme overrides into every subsequent render until a colour
#on/off state flip forced an array reload.)
array set CLR [array get arg_error_CLR]
if {[llength $args] %2 != 0} {
set arg_error_isrunning 0
error "error in arg_error processing - expected opt/val pairs after msg and spec_dict"
}
set arg_error_isrunning 1
set badarg ""
set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse)
set parsestatus "" ;#parse-status structure (see ::punk::args::parse_status) - takes precedence over -badarg/-parsedargs
#-----------------------
#todo!! make changeable from config file
#JJJ 2025-07-16
set returntype table ;#table as string
#set returntype string
#----------------------
set as_error 1 ;#usual case is to raise an error
set scheme error
set form 0
dict for {k v} $args {
set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -parsestatus -aserror -return -scheme -form} $k]
switch -- $fullk {
-badarg {
set badarg $v
}
-parsedargs {
set parsedargs $v
}
-parsestatus {
set parsestatus $v
}
-aserror {
if {![string is boolean -strict $v]} {
set arg_error_isrunning 0
error "arg_error invalid value for option -aserror. Received '$v' expected a boolean"
}
set as_error $v
}
-scheme {
set scheme $v
}
-return {
if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} {
set arg_error_isrunning 0
error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject"
}
set returntype $v
}
-form {
set form $v
}
default {
set arg_error_isrunning 0
error "arg_error invalid option $k. Known_options: -badarg -parsedargs -parsestatus -aserror -scheme -return -form"
}
}
}
#todo - scheme - use config and iterm toml definitions etc
switch -- $scheme {
"" - nocolor - nocolour - -nocolor - -nocolour {
#the documented choice value is 'nocolour' - dash spellings and 'nocolor'
#accepted for backward compatibility
set scheme nocolour
}
info - error {}
default {
set scheme na
}
}
set formnames [dict get $spec_dict form_names]
#G-041: -form accepts a list of form names/indices - supplied order is preserved
#(the first selected form is the one the argument table renders; all selected
#forms have their synopsis entries marked)
if {[catch {private::form_selection $formnames $form "arg_error"} selected_forms]} {
set arg_error_isrunning 0
error "arg_error invalid value for option -form. Received '$form' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'"
}
#hack some basics for now.
#for coloured schemes - use bold as well as brightcolour in case colour off.
#CLR is a proc-local copy of arg_error_CLR (see above)
#The nocolour,info,error arrays have overrides for some keys.
switch -- $scheme {
nocolour {
variable arg_error_CLR_nocolour
array set CLR [array get arg_error_CLR_nocolour]
}
info {
variable arg_error_CLR_info
array set CLR [array get arg_error_CLR_info]
}
error {
variable arg_error_CLR_error
array set CLR [array get arg_error_CLR_error]
}
na {
}
}
#parse-status structure the renderers derive goodarg/badarg row marking and choice
#value-in-effect highlighting from (see ::punk::args::parse_status for the shape).
#An explicit -parsestatus takes precedence; otherwise build one for the displayed
#form from the -parsedargs/-badarg primitives.
if {$parsestatus ne ""} {
set PSTAT $parsestatus
} else {
set PSTAT [private::parse_status_build $spec_dict [lindex $selected_forms 0] -badarg $badarg -parsedargs $parsedargs]
}
set argstatusd [dict get $PSTAT argstatus]
set receivednames [dict get $PSTAT receivednames]
#set RST [a]
set RST "\x1b\[0m"
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 {!$has_textblock && ($returntype in {table tableobject})} {
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 cmdsummary [Dict_getdef $spec_dict cmd_info -summary ""]
set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""]
#===========
#@cmd -unindentedfields {-help} means the help text is authored at the left
#margin: skip the display-time indent transform (goal G-045; same gate as
#argument -help below)
if {"-help" ni [Dict_getdef $spec_dict cmd_info -unindentedfields {}]} {
set maxundent 4
set cmdhelp [punk::lib::undent " $cmdhelp" $maxundent]
}
#===========
set docname [Dict_getdef $spec_dict doc_info -name "Manual:"]
set docurl [Dict_getdef $spec_dict doc_info -url ""]
#set example [Dict_getdef $spec_dict examples_info -help ""]
set has_example [dict exists $spec_dict examples_info -help]
#review - when can there be more than one selected form?
set argdisplay_header ""
set argdisplay_body ""
if {[llength $selected_forms] == 1} {
set fid [lindex $selected_forms 0]
set FRM [dict get $spec_dict FORMS $fid]
if {[dict size [dict get $FRM FORMDISPLAY]]} {
set argdisplay_header [Dict_getdef $FRM FORMDISPLAY -header ""]
set argdisplay_body [Dict_getdef $FRM FORMDISPLAY -body ""]
}
}
# if {![dict size $F $fid $FORMDISPLAY]} {}
#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 is_custom_argdisplay 0
set blank_header_col [list]
if {$cmdname ne ""} {
lappend blank_header_col ""
set cmdname_display $CLR(cmdname)$cmdname$RST
} else {
set cmdname_display ""
}
if {$cmdhelp ne ""} {
lappend blank_header_col ""
#set cmdhelp_display [a+ brightwhite]$cmdhelp[a]
#set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)]
set cmdhelp [punk::args::helpers::strip_nodisplay_lines $cmdhelp]
set cmdhelp_display [punk::ansi::ansiwrap_raw $CLR(linebase_header) "" "" $cmdhelp]
} else {
set cmdhelp_display ""
}
if {$docurl ne ""} {
lappend blank_header_col ""
set docurl_display [a+ white]$docurl$RST
} else {
set docurl_display ""
}
if {$has_example} {
lappend blank_header_col ""
set example_display "[a+ white]eg [dict get $spec_dict id]$RST"
} else {
set example_display ""
}
#synopsis
set synopsis "# [Dict_getdef $spec_dict cmd_info -summary {}]\n"
set form_info [dict get $spec_dict form_info]
dict for {fid finfo} $form_info {
set form_synopsis [Dict_getdef $finfo -synopsis ""]
if {$form_synopsis eq ""} {
#todo
set form_synopsis [punk::args::synopsis -noheader -form $fid [dict get $spec_dict id]]
set ansifree_synopsis [punk::ansi::ansistripraw $form_synopsis]
if {[string length $ansifree_synopsis] > 90} {
#
set form_synopsis [punk::args::synopsis -noheader -return summary -form $fid [dict get $spec_dict id]]
}
#review
if {[string match (autodef)* $form_synopsis]} {
set form_synopsis [string range $form_synopsis 9 end]
}
}
if {$fid in $selected_forms} {
set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline]
}
append synopsis $form_synopsis \n
}
if {$synopsis ne ""} {
set synopsis [string trimright $synopsis \n]
lappend blank_header_col ""
}
if {$argdisplay_header ne ""} {
lappend blank_header_col ""
}
if {$use_table} {
set t [textblock::class::table new "$CLR(title)Usage$RST"]
$t add_column -headers $blank_header_col -minwidth 3
$t add_column -headers $blank_header_col
if {!$is_custom_argdisplay} {
lappend blank_header_col ""
#spanned columns in default argdisplay area
$t add_column -headers $blank_header_col ;#Default
$t add_column -headers $blank_header_col ;#Multi
$t add_column -headers $blank_header_col ;#Help
set arg_colspans {1 4 0 0 0}
} else {
if {$argdisplay_header ne ""} {
lappend blank_header_col ""
}
set arg_colspans {1 1}
}
}
set h 0
if {$cmdname ne ""} {
if {$use_table} {
$t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display]
} else {
lappend errlines "COMMAND: $cmdname_display"
}
incr h
}
if {$cmdhelp ne ""} {
if {$use_table} {
$t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display]
} else {
#align continuation lines under the first line as the table renderer's
#cell does - relative indents among continuations preserved (G-046 item 4)
set desclines [split $cmdhelp_display \n]
set labelpad [string repeat " " [string length "Description: "]]
set descjoined [lindex $desclines 0]
foreach dline [lrange $desclines 1 end] {
if {$dline eq ""} {
append descjoined \n
} else {
append descjoined \n $labelpad $dline
}
}
lappend errlines "Description: $descjoined"
}
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 {$has_example} {
if {$use_table} {
$t configure_header $h -colspans $arg_colspans -values [list Example: $example_display]
} else {
lappend errlines "Example: $example_display"
}
incr h
}
if {$synopsis ne ""} {
if {$use_table} {
set form_names [dict get $spec_dict form_names]
set synhelp "Synopsis:"
if {[llength $form_names] > 1} {
set fn 0
foreach fname $form_names {
append synhelp \n " i -form $fn \U2026"
incr fn
}
}
$t configure_header $h -colspans $arg_colspans -values [list $synhelp [punk::ansi::ansiwrap brightwhite $synopsis]]
} else {
#todo
lappend errlines "Synopsis:\n$synopsis"
}
incr h
}
if {$use_table} {
if {$is_custom_argdisplay} {
if {$argdisplay_header ne ""} {
$t configure_header $h -colspans {2 0} -values [list $argdisplay_header]
}
} else {
$t configure_header $h -values {Arg Type Default Multi Help}
}
} else {
lappend errlines " --ARGUMENTS-- "
}
if {$is_custom_argdisplay} {
if {$use_table} {
#using overall container table
#header already added
#TODO - review textblock::table features
#we can't currently span columns within the table body.
#This feature could allow hidden data columns (and sort on hidden col?)
#potentially require coordination with header colspans?
$t add_row [list "" $argdisplay_body]
} else {
if {$argdisplay_header ne ""} {
lappend errlines $argdisplay_header
}
lappend errlines {*}$argdisplay_body
}
} else {
#set A_DEFAULT [a+ brightwhite Brightgreen]
set A_DEFAULT ""
set A_BADARG $CLR(badarg)
set A_GOODARG $CLR(goodarg)
set A_GOODCHOICE $CLR(goodchoice)
set greencheck $CLR(check)\u2713$RST ;#green tick
set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?)
set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply
if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} {
#A_PREFIX can resolve to empty string if colour off
#we then want to display underline instead
set A_PREFIX [a+ underline]
#set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space (zwsp)
set A_PREFIXEND [a+ nounderline]
#review - zwsp problematic on older terminals that print it visibly
#- especially if they also lie about cursor position after it's emitted.
#so although the zwsp fixes the issue where the underline extends to rhs padding if all text was underlined,
#It's probably best fixed in the padding functionality.
} else {
set A_PREFIXEND $RST
}
#TODO - foreach fid
set fid [lindex $selected_forms 0]
set form_dict [dict get $spec_dict FORMS $fid]
set opt_names [list]
set opt_names_display [list]
set opt_names_hints [list] ;#comments in first column below name display.
set lookup_optset [dict create]
if {[llength [dict get $form_dict OPT_NAMES]]} {
set all_opts [list]
foreach optionset [dict get $form_dict OPT_NAMES] {
#e.g1 "-alias1|-realname"
#e.g2 "-f|--filename" (fossil longopt style)
#e.g3 "-f|--filename=" (gnu longopt style)
set optmembers [split $optionset |]
lappend all_opts {*}$optmembers
foreach o $optmembers {
dict set lookup_optset $o $optionset
#goodargs
}
}
#received-name normalization to optionset names (formerly done here on the
#transient goodargs local) lives in private::parse_status_build - the
#renderers below consume $argstatusd/$receivednames from the structure
if {![catch {package require punk::trie}]} {
#todo - reservelist for future options - or just to affect the prefix calculation
# (similar to -choiceprefixreservelist)
set trie [punk::trie::trieclass new {*}$all_opts --]
set idents [dict get [$trie shortest_idents ""] scanned]
if {[llength [dict get $form_dict OPT_MASHES]]} {
set all_mash_letters [dict get $form_dict OPT_ALL_MASH_LETTERS]
#now extend idents to be at least as long as the number of mash/bundle flags that exist.
#(when the flag itself is longer than number of mash flags
# - e.g for flags -x -v -c -f -collection, the ident for -collection would be -co normally
# but if we have 4 mash flags, we want it to be -colle to satisfy the requirement that it is longer then the number of mash flags
# unless it is an exact match.)
#
#e.g if all the single letter flags are configured with -mash true:
#our prefix calculation might give us the following idents:
# idents: -cabinet -ca -a -a -b -b -c -c -- --
#we need only to extend -cabinet to -cabi to satisfy the requirement that it is longer than the number of mash flags (3 in this example because -- is never a mash flag)
dict for {fullname ident} $idents {
set mashcount [llength $all_mash_letters]
#assert: if we are here - mashcount > 0
if {[string length $ident] < [string length $fullname] && [string length $ident] <= $mashcount} {
dict set idents $fullname [string range $fullname 0 $mashcount+1]
}
}
#note it's still possible for the user to define a flag with a name shorter than the number of mash flags
# and it could even overlap with a specific combination of mash letters - e.g -a -b -c -d and a flag named -bac
# - in this case a provided value of -bac would still match the flag -bac rather than being treated as a mash of -b -a -c
#because the exact match will take priority over the prefix match.
#Whilst this configuration is accepted - it's not recommended.
}
#todo - check opt_prefixdeny
$trie destroy
foreach optset [dict get $form_dict OPT_NAMES] {
set arginfo [dict get $form_dict ARG_INFO $optset]
set parsekey [dict get $arginfo -parsekey]
set storageinfo ""
if {$parsekey ne "" && $parsekey ne $optset} {
set storageinfo " $CLR(parsekey_hint)(parsekey: $parsekey)$RST" ;#indent as a hint that it's related to the opt above it - maybe also use a different colour or style?
}
if {[dict get $arginfo -prefix]} {
set opt_members [split $optset |]
set odisplay [list]
foreach opt $opt_members {
set id [dict get $idents $opt]
#REVIEW
if {$id eq $opt} {
set prefix $opt
set tail ""
} else {
set idlen [string length $id]
lassign [punk::lib::string_splitbefore $opt $idlen] prefix tail
}
lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail
}
#lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail
lappend opt_names_display [join $odisplay |]
} else {
lappend opt_names_display $optset
}
lappend opt_names_hints $storageinfo
#lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail]
lappend opt_names $optset
}
} else {
set opt_names [dict get $form_dict OPT_NAMES]
foreach optset [dict get $form_dict OPT_NAMES] {
set arginfo [dict get $form_dict ARG_INFO $optset]
set parsekey [dict get $arginfo -parsekey]
set storageinfo ""
if {$parsekey ne "" && $parsekey ne $optset} {
set storageinfo "(stored as: $parsekey)"
}
lappend opt_names_display $optset
lappend opt_names_hints $storageinfo
}
#set opt_names_display $opt_names
}
}
set leading_val_names [dict get $form_dict LEADER_NAMES]
set trailing_val_names [dict get $form_dict VAL_NAMES]
#dict for {argname info} [tcl::dict::get $form_dict arg_info] {
# if {![string match -* $argname]} {
# lappend leading_val_names [lpop trailing_val_names 0]
# } else {
# break
# }
#}
#if {![llength $leading_val_names] && ![llength $opt_names]} {
# #all vals were actually trailing - no opts
# set trailing_val_names $leading_val_names
# set leading_val_names {}
#}
set leading_val_names_display $leading_val_names
set leading_val_names_hints {}
set trailing_val_names_display $trailing_val_names
set trailing_val_names_hints {}
#display options first then values
foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names_hints $leading_val_names] [list opts $opt_names_display $opt_names_hints $opt_names] [list values $trailing_val_names_display $trailing_val_names_hints $trailing_val_names]] {
lassign $argumentclassinfo argumentclass argnames_display argnames_hints argnames
set lastgroup ""
set lastgroup_parsekey ""
foreach argshow $argnames_display hint $argnames_hints arg $argnames {
set arginfo [dict get $form_dict ARG_INFO $arg]
#this argument's entry in the parse-status structure: row marking from
#its status, choice value-in-effect highlighting from hasvalue/value
if {[dict exists $argstatusd $arg]} {
set arg_status [dict get $argstatusd $arg status]
set arg_hasvalue [dict get $argstatusd $arg hasvalue]
set arg_value [dict get $argstatusd $arg value]
} else {
set arg_status unparsed
set arg_hasvalue 0
set arg_value ""
}
if {$argumentclass eq "opts"} {
set thisgroup [dict get $arginfo -group]
if {$thisgroup ne $lastgroup} {
if {[dict exists $form_dict OPT_GROUPS $thisgroup -parsekey]} {
set thisgroup_parsekey [dict get $form_dict OPT_GROUPS $thisgroup -parsekey]
} else {
set thisgroup_parsekey ""
}
#footer/line?
if {$use_table} {
$t add_row [list " " "" "" "" ""]
} else {
lappend errlines " "
}
if {$thisgroup eq ""} {
} else {
#SHOW group 'header' (not really a table header - just another row)
set help ""
if {[dict exists $form_dict OPT_GROUPS $thisgroup -help]} {
set help [dict get $form_dict OPT_GROUPS $thisgroup -help]
#field in @directiveline was -grouphelp
#review - where to specify -unindentedfields for a group? do we really need it?
#if {"-grouphelp" ni $unindentedfields} {
set maxundent 4
set help " $help"
set help [punk::lib::undent $help $maxundent]
#}
}
if {$thisgroup_parsekey eq ""} {
set groupinfo "(documentation group)"
} else {
set groupinfo "(common flag group)\nkey:$thisgroup_parsekey"
}
if {$use_table} {
$t add_row [list " $thisgroup" $groupinfo "" "" $help]
if {$arg_status eq "bad"} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG
} elseif {$arg_status eq "ok" || $thisgroup_parsekey in $receivednames} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG
}
} else {
#review - formatting will be all over the shop due to newlines in typesshow, help
#set arghelp "[a+ bold] $thisgroup$RST $groupinfo"
set arghelp [textblock::join -- "[a+ bold] $thisgroup$RST" " " $groupinfo]
append arghelp \n
if {$arg_status eq "bad"} {
set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp]
} elseif {$arg_status eq "ok"} {
set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp]
}
foreach ln [split $help \n] {
append arghelp " $ln" \n
}
lappend errlines $arghelp
}
}
set lastgroup $thisgroup
set lastgroup_parsekey $thisgroup_parsekey
}
if {[dict exists $arginfo -parsekey]} {
set mypkey [dict get $arginfo -parsekey]
if {$mypkey eq "$lastgroup_parsekey" || $mypkey eq [string trimright [lindex [split $arg |] end] =]} {
set hint ""
}
}
}
if {[dict exists $arginfo -default]} {
#default isn't necessarily of same type as -type required for validation
#Guessing at the type from the data is likely to be unsatisfactory.
set defaultdisplaytype [Dict_getdef $arginfo -defaultdisplaytype string]
switch -- $defaultdisplaytype {
dict {
#single level
set rawdefault [dict get $arginfo -default]
set default "{\n"
dict for {k v} $rawdefault {
append default " \"$k\" \"$v\"\n"
}
append default "}"
}
list {
set default "{\n"
foreach v $rawdefault {
append default " \"$v\"\n"
}
append default "}"
}
default {
#set default "'$A_DEFAULT[dict get $arginfo -default]$RST'"
set default "'[dict get $arginfo -default]'"
}
}
} else {
set default ""
}
set unindentedfields [Dict_getdef $arginfo -unindentedfields {}]
set help [Dict_getdef $arginfo -help ""]
set help [punk::args::helpers::strip_nodisplay_lines $help]
set allchoices_originalcase [list]
set choices [Dict_getdef $arginfo -choices {}]
set choicegroups [Dict_getdef $arginfo -choicegroups {}]
set choicemultiple [dict get $arginfo -choicemultiple]
if {[string is integer -strict $choicemultiple]} {
set choicemultiple [list $choicemultiple $choicemultiple]
}
lassign $choicemultiple choicemultiple_min choicemultiple_max
set choicecolumns [Dict_getdef $arginfo -choicecolumns 4]
set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}]
set choiceprefixreservelist [Dict_getdef $arginfo -choiceprefixreservelist {}] ;#names used to calc prefix - but not available as actual choice.
if {[Dict_getdef $arginfo -multiple 0]} {
set multiple $greencheck
set is_multiple 1
} else {
set multiple ""
set is_multiple 0
}
if {[dict exists $choicegroups ""]} {
dict lappend choicegroups "" {*}$choices
} else {
set choicegroups [dict merge [dict create "" $choices] $choicegroups]
}
#review - does choiceprefixdenylist need to be added?
dict for {groupname clist} $choicegroups {
lappend allchoices_originalcase {*}$clist
}
set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}]
if {$has_choices} {
if {$help ne ""} {append help \n}
#G-040: alias names participate in prefix calculation (as at parse time)
set choicealiases_display [Dict_getdef $arginfo -choicealiases {}]
set choicealias_names [dict keys $choicealiases_display]
if {[dict get $arginfo -nocase]} {
set casemsg " (case insensitive)"
set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}[string tolower $choicealias_names] {*}$choiceprefixreservelist]
} else {
set casemsg " (case sensitive)"
set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choicealias_names {*}$choiceprefixreservelist]
}
if {[dict get $arginfo -choiceprefix]} {
set prefixmsg " (choice prefix allowed)"
} else {
set prefixmsg ""
}
set choicelabeldict [Dict_getdef $arginfo -choicelabels {}]
set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}]
#G-040: aliases are not displayed as separate choice entries - fold each
#canonical's alias names into its label so every display path shows them once
if {[dict size $choicealiases_display]} {
set aliasesbycanonical [dict create]
dict for {ca_al ca_cn} $choicealiases_display {
dict lappend aliasesbycanonical $ca_cn $ca_al
}
dict for {ca_cn ca_als} $aliasesbycanonical {
set aliasnote "(alias[expr {[llength $ca_als] > 1 ? {es} : {}}]: [join $ca_als |])"
if {[dict exists $choicelabeldict $ca_cn]} {
dict set choicelabeldict $ca_cn "$aliasnote\n[dict get $choicelabeldict $ca_cn]"
} else {
dict set choicelabeldict $ca_cn $aliasnote
}
}
}
set formattedchoices [dict create] ;#use dict rather than array to preserve order
if {$help eq ""} {
#first line of help - no included base of 4 indent is the normal state of first help lines in definitions scripts
#align fully left to distinguish from previous argument help text
append help "Choices$prefixmsg$casemsg"
} else {
#we are on a subsequent line of -help. Indent the usual base of 4 + desired offset
#offset of 2 to align with choices table
append help " Choices$prefixmsg$casemsg"
}
if {$choicemultiple_max > 1 || $choicemultiple_max == -1} {
if {$choicemultiple_max == -1} {
append help \n " The value can be a list of $choicemultiple_min or more of these choices"
} else {
if {$choicemultiple_min eq $choicemultiple_max} {
append help \n " The value must be a list of $choicemultiple_min of these choices"
} else {
append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices"
}
}
}
if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} {
#append help "\n " [join [dict get $arginfo -choices] "\n "]
if {[dict size $choicelabeldict]} {
dict for {groupname clist} $choicegroups {
foreach c $clist {
set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict]
if {[llength $markers]} {
set cdisplay "$c [join $markers {}]"
} else {
set cdisplay $c
}
if {[dict exists $choicelabeldict $c]} {
#append cdisplay \n [dict get $choicelabeldict $c]
if {"-choicelabels" ni $unindentedfields} {
set maxundent 4
set ctext " [dict get $choicelabeldict $c]"
set ctext [punk::lib::undent $ctext $maxundent]
} else {
set ctext [dict get $choicelabeldict $c]
}
append cdisplay \n $ctext
}
if {$arg_hasvalue && $arg_value eq $c} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} elseif {$arg_hasvalue && $is_multiple && $c in $arg_value} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} else {
dict lappend formattedchoices $groupname $cdisplay
}
}
}
} else {
#set formattedchoices $choicegroups
#set formattedchoices [dict get $arginfo -choices]
dict for {groupname clist} $choicegroups {
foreach c $clist {
set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict]
if {[llength $markers]} {
set cdisplay "$c [join $markers {}]"
} else {
set cdisplay $c
}
if {$arg_hasvalue && $arg_value eq $c} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} elseif {$arg_hasvalue && $is_multiple && $c in $arg_value} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} else {
dict lappend formattedchoices $groupname $cdisplay
}
}
}
}
} else {
if {[catch {
set trie [punk::trie::trieclass new {*}$allchoices_prefixcalc]
set idents [dict get [$trie shortest_idents ""] scanned]
if {[dict get $arginfo -nocase]} {
#idents were calculated on lcase - remap keys in idents to original casing
set actual_idents $idents
foreach ch $allchoices_originalcase {
if {![dict exists $idents $ch]} {
#don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting
#The actual testing is done in get_dict
dict set actual_idents $ch [dict get $idents [string tolower $ch]]
}
}
set idents $actual_idents
#puts "-----"
#puts "idents $idents"
}
$trie destroy
dict for {groupname clist} $choicegroups {
foreach c $clist {
if {$c in $choiceprefixdenylist} {
set shortestid $c
} else {
set shortestid [dict get $idents $c]
}
lassign [punk::lib::string_splitbefore $c [string length $shortestid]] prefix tail
#if {$shortestid eq $c} {
# set prefix $c
# set tail ""
#} else {
# set idlen [string length $shortestid]
# set prefix [string range $c 0 $idlen-1]
# set tail [string range $c $idlen end]
#}
set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict]
if {[llength $markers]} {
set mk " [join $markers {}]"
} else {
set mk ""
}
set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk"
if {[dict exists $choicelabeldict $c]} {
#append cdisplay \n [dict get $choicelabeldict $c]
#undent
if {"-choicelabels" ni $unindentedfields} {
set maxundent 4
set ctext " [dict get $choicelabeldict $c]"
set ctext [punk::lib::undent $ctext $maxundent]
} else {
set ctext [dict get $choicelabeldict $c]
}
append cdisplay \n $ctext
}
#puts "-- parsed:$parsedvalues arg:$arg c:$c"
if {$arg_hasvalue && $arg_value eq $c} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} elseif {$arg_hasvalue && $is_multiple && $c in $arg_value} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} else {
dict lappend formattedchoices $groupname $cdisplay
}
}
}
} errM]} {
#this failure can happen if -nocase is true and there are ambiguous entries
#e.g -nocase 1 -choices {x X}
puts stderr "prefix marking failed\n$errM"
#append help "\n " [join [dict get $arginfo -choices] "\n "]
if {[dict size $choicelabeldict]} {
dict for {groupname clist} $choicegroups {
foreach c $clist {
set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict]
if {[llength $markers]} {
set cdisplay "$c [join $markers {}]"
} else {
set cdisplay $c
}
if {[dict exists $choicelabeldict $c]} {
append cdisplay \n [dict get $choicelabeldict $c]
}
if {$arg_hasvalue && $arg_value eq $c} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} else {
dict lappend formattedchoices $groupname $cdisplay
}
}
}
} else {
#set formattedchoices $choicegroups
dict for {groupname clist} $choicegroups {
foreach c $clist {
set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict]
if {[llength $markers]} {
set cdisplay "$c[join $markers {}]"
} else {
set cdisplay $c
}
if {$arg_hasvalue && $arg_value eq $c} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} elseif {$arg_hasvalue && $is_multiple && $c in $arg_value} {
dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay]
} else {
dict lappend formattedchoices $groupname $cdisplay
}
}
}
}
}
}
set choicetable_objects [list]
set choicetable_footers [dict create]
dict for {groupname formatted} $formattedchoices {
set numcols $choicecolumns ;#todo - dynamic?
if {[llength $formatted] < $numcols} {
#don't show blank cells if single line of results
set numcols [llength $formatted]
}
if {$numcols > 0} {
if {$use_table} {
#risk of recursing
#TODO -title directly in list_as_table
set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted]
lappend choicetable_objects $choicetableobj
$choicetableobj configure -title $CLR(groupname)$groupname
#append help \n[textblock::join -- " " [$choicetableobj print]]
} else {
if {$groupname ne ""} {
append help \n \n "$CLR(groupname)Group: $groupname$RST"
} else {
append help \n
}
append help \n [join $formatted \n]
}
} else {
#we were given an empty set of choices.
#probably an error in the definition - but could happen if dynamically generated.
#(e.g ensemble where unknown mechanism is used for subcommands?)
#better to just display that there were none rather than totally break the usage output.
if {$usetable} {
#these will be displayed after all table entries
if {$groupname eq ""} {
dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST"
} else {
dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST"
}
} else {
if {$groupname eq ""} {
append help \n " " $CLR(errormsg)(no choices defined)$RST
} else {
append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST
}
}
}
}
set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width
foreach obj $choicetable_objects {
dict lappend twidths_by_colcount [$obj column_count] [$obj width]
}
foreach obj $choicetable_objects {
set cols [$obj column_count]
set widths [dict get $twidths_by_colcount $cols]
set max [tcl::mathfunc::max {*}$widths]
$obj configure -minwidth $max ;#expand smaller ones
set i 0
while {$i < $cols} {
#keep text aligned left on expanded tables
$obj configure_column $i -blockalign left
incr i
}
append help \n[textblock::join -- " " [$obj print]] ;#4 for standard source-layout indent + 2
#-------------
#todo - tests
#see special case double reset at end of content in textblock class table get_column_by_index
#bug fixed - needed to ensure last two resets were actually concurrent and at end.
#append help "\nbase[a+ green]ab\nc[a]base" ;#ok
#vs
#append help "\nbase[a+ green]a[a]b\nc[a]base" ;#not ok
#-------------
#set ansititle [dict get [$obj configure -title] value]
$obj destroy
}
if {[dict size $choicetable_footers]} {
foreach groupname [dict keys $formattedchoices] {
if {[dict exists $choicetable_footers $groupname]} {
append help \n [dict get $choicetable_footers $groupname]
}
}
}
#review. use -type to restrict additional choices - may be different to values in the -choices
if {![dict get $arginfo -choicerestricted]} {
#when -choicemultiple - the -type refers to each selection
if {[dict get $arginfo -type] eq "string"} {
append help "\n (values not in defined choices are allowed)"
} else {
append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])"
}
}
}
if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} {
if {$is_multiple} {
set argshow "?${argshow}...?"
} else {
set argshow "?${argshow}?"
}
} else {
if {$is_multiple} {
set argshow "${argshow}..."
}
}
set typeshow [dict get $arginfo -type]
if {$typeshow eq "none"} {
set typeshow "$typeshow $soloflag"
}
if {[dict exists $arginfo -minsize]} {
append typeshow \n "-minsize [dict get $arginfo -minsize]"
}
if {[dict exists $arginfo -maxsize]} {
append typeshow \n "-maxsize [dict get $arginfo -maxsize]"
}
if {[dict exists $arginfo -typeranges]} {
set ranges [dict get $arginfo -typeranges]
if {[llength $ranges] == 1} {
append typeshow \n "-range [lindex [dict get $arginfo -typeranges] 0]"
} else {
append typeshow \n "-ranges"
foreach r $ranges {
append typeshow " {$r}"
}
}
}
# =============================================
#REVIEW
if {"-help" ni $unindentedfields} {
# see punk::args::resolve
set maxundent 4
set help [punk::lib::undent " $help" $maxundent]
}
# =============================================
if {$use_table} {
if {$hint ne ""} {
set col1 $argshow\n$hint
} else {
set col1 $argshow
}
$t add_row [list $col1 $typeshow $default $multiple $help]
if {$arg_status eq "bad"} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG
} elseif {$arg_status eq "ok"} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG
}
} else {
#review - formatting will be all over the shop due to newlines in typesshow, help
set linetail " TYPE:$typeshow DEFAULT:$default MULTI:$multiple"
if {$hint ne ""} {
set arghelp [textblock::join -- "[a+ bold]$argshow\n$hint$RST" $linetail]
} else {
set arghelp "[a+ bold]$argshow$RST $linetail"
}
append arghelp \n
if {$arg_status eq "bad"} {
set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp]
} elseif {$arg_status eq "ok"} {
set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp]
}
foreach ln [split $help \n] {
append arghelp " $ln" \n
}
lappend errlines $arghelp
}
}
# -------------------------------------------------------------------------------------------------------
# if the argument class can accept unnamed arguments (or if opts accepts unspecified flags) - display an indication
# -------------------------------------------------------------------------------------------------------
switch -- $argumentclass {
leaders - values {
if {$argumentclass eq "leaders"} {
set class_unnamed LEADER_UNNAMED
set class_max LEADER_MAX
set class_required LEADER_REQUIRED
set class_directive_defaults LEADERSPEC_DEFAULTS
} else {
set class_unnamed VAL_UNNAMED
set class_max VAL_MAX
set class_required VAL_REQUIRED
set class_directive_defaults VALSPEC_DEFAULTS
}
if {[dict get $form_dict $class_unnamed]} {
set valmax [dict get $form_dict $class_max]
#set valmin [dict get $form_dict VAL_MIN]
if {$valmax eq ""} {
set valmax -1
}
if {$valmax == -1} {
set possible_unnamed -1
} else {
set possible_unnamed [expr {$valmax - [llength [dict get $form_dict $class_required]]}]
if {$possible_unnamed < 0} {
set possible_unnamed 0
}
}
if {$possible_unnamed == -1 || $possible_unnamed > 0} {
#Note 'multiple' is always empty here as each unnamed is assigned to its own positional index
if {$possible_unnamed == 1} {
set argshow ?<unnamed>?
} else {
set argshow ?<unnamed>...?
}
set tp [dict get $form_dict $class_directive_defaults -type]
if {[dict exists $form_dict $class_directive_defaults -default]} {
set default [dict get $form_dict $class_directive_defaults -default]
} else {
set default ""
}
if {$use_table} {
$t add_row [list "$argshow" $tp $default "" ""]
} else {
set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n"
lappend errlines $arghelp
}
}
}
}
opts {
#display row to indicate if -any|-arbitrary true
#review OPTSPEC_DEFAULTS -multiple ?
if {[dict get $form_dict OPT_ANY]} {
set argshow "?<arbitrary-flag>...?"
set tp [dict get $form_dict OPTSPEC_DEFAULTS -type]
if {[dict exists $form_dict OPTSPEC_DEFAULTS -default]} {
set default [dict get $form_dict OPTSPEC_DEFAULTS -default]
} else {
set default ""
}
if {$use_table} {
$t add_row [list "$argshow" $tp $default "" ""]
} else {
set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n"
lappend errlines $arghelp
}
}
}
}
} ;#end foreach argumentclass
} ;#end is_custom_argdisplay
if {$use_table} {
$t configure -show_hseps 0 {*}{
-show_header 1
} -ansibase_body $CLR(ansibase_body) {*}{
} -ansibase_header $CLR(ansibase_header) {*}{
} -ansiborder_header $CLR(ansiborder) {*}{
} -ansiborder_body $CLR(ansiborder)
$t configure -maxwidth 80 ;#review
if {$returntype ne "tableobject"} {
append errmsg [$t print]
#returntype of table means just the text of the table
$t destroy
}
} else {
append errmsg [join $errlines \n]
}
} errM]} {
append errmsg \n
append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n
append errmsg "$errM" \n
append errmsg "$::errorInfo"
catch {$t destroy}
}
set arg_error_isrunning 0
if {$use_table} {
#assert returntype is one of table, tableobject
set result $errmsg ;#default if for some reason table couldn't be used
if {$returntype eq "tableobject"} {
if {[info object isa object $t]} {
set result $t
}
} else {
#put original error at bottom of table too
append result \n $msg
}
} else {
set result $errmsg
append result \n $msg
}
if {$as_error} {
#add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it.
#Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;)
uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result]
} else {
return $result
}
}
lappend PUNKARGS [list {
@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::cmdhelp (aliased as i in the punk shell) should
be used in preference - as it will search for a documentation
mechanism and call punk::args::usage as necessary.
"
-return -default table -choices {string table tableobject}
}\
{${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\
{${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\
{
@values -min 0 -max 1
id -help\
"Exact id.
Will usually match the command name"
}]
proc usage {args} {
lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received
set id [dict get $values id]
set real_id [real_id $id]
if {$real_id eq ""} {
error "punk::args::usage - no such id: $id"
}
#-scheme punk_info ??
arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0
}
lappend PUNKARGS [list {
@id -id ::punk::args::get_by_id
@cmd -name punk::args::get_by_id
@values -min 1
id
arglist -type list -help\
"list containing arguments to be parsed as per the
argument specification identified by the supplied id."
}]
#deprecate?
proc get_by_id {id arglist} {
set definitionlist [punk::args::raw_def $id]
if {[llength $definitionlist] == 0} {
error "punk::args::get_by_id - no such id: $id"
}
#uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist]
tailcall ::punk::args::get_dict $definitionlist $arglist
}
#consider
#require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own)
#parse ?-flag val?... -- $arglist withid $id
#parse ?-flag val?... -- $arglist withdef $def ?$def?...
#an experiment.. ideally we'd like arglist at the end?
#parse_withid ?-flag val?.. $id $arglist
#parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax?
#no possible equivalent for parse_withdef ???
lappend PUNKARGS [list {
@id -id ::punk::args::parse
@cmd -name punk::args::parse -help\
{parse and validate command arguments based on a definition.
In the 'withid' form the definition is a pre-existing record that has been
created with ::punk::args::define, or indirectly by adding a definition to
the PUNKARGS variable in a namespace which is then registered in
punk::args::register::NAMESPACES, or by a previous call to punk::parse
using 'withdef' and a definition block containing an @id -id <id> directive.
In the 'withdef' form - the definition is created on the first call and
cached thereafter, if the id didn't already exist.
form1: parse $arglist ?-flag val?... withid $id
form2: parse $arglist ?-flag val?... withdef $def ?$def?
see punk::args::define
Returns a dict of information regarding the parsed arguments
example of basic usage for single option only:
${[punk::args::helpers::example {
punk::args::define {
@id -id ::myns::myfunc
@cmd -name myns::myfunc
@leaders -min 0 -max 0
@opts
-configfile -type existingfile
#type none makes it a solo flag
-verbose -type none
@values -min 0 -max 0
}
proc myfunc {args} {
set argd [punk::args::parse $args withid ::myns::myfunc]
lassign [dict values $argd] leaders opts values received solos
if {[dict exists $received] -configfile} {
puts "have option for existing file [dict get $opts -configfile]"
}
}
}]}
The leaders, opts, values keys in the parse result dict are proper dicts.
The received key is dict-like but can have repeated keys for arguments than can
accept multiples.
The value for each received element is the ordinal position of each clause.
ie in the common case where each argument is a single value, the ordinal positiion
will correspond too the position of the argument in the arglist. But if an argument can be
a clause of multiple values (possibly with some values in the clause being optional), then
there will not be a direct correlation between the position of the argument in the arglist
and the ordinal position of the clause received for that argument.
An example of a multivalued clause is an argument defined with a -type that has multiple elements,
e.g coord -type {int int}. This is a dictinct situation to an argument defined with -multiple true
where the argument can be repeated but each clause is a single value.
In the coord example, if it is also designated with -multiple true, the first clause received for the coord
argument would have an ordinal position of 0, and the second clause received for the coord argument would
have an ordinal position of 1.
eg for a call: myfunc 1 2 3 4 where the definition for myfunc is:
@id -id ::myfunc
@values
coord -type {int int} -multiple true
the parse result would have a received dict of:
received {coord 0 coord 1}
The solos key refers to a list of solo flags received (those specified with
-type none). This is generally only useful to assist in passing arguments on
to another procedure which also requires solos, because the opts dict contains
solo flags with a 1 value or a list of 1's if it was a solo with -multiple true
specified.
The form key records the name of the form the arguments were parsed against
(multiform definitions declare forms with the @form directive - see
punk::args::define). When -form permits several forms, the form that
auto-selection settled on is reported here, and a formstatus key is added
recording each attempted form's outcome (see punk::args::parse_status).
}
@form -form {withid withdef}
@leaders -min 1 -max 1
arglist -type list -optional 0 -help\
"Arguments to parse - supplied as a single list"
@opts -prefix 0
-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. Each list element is an ordinal index or
a form name.
With the default * (or a multi-form selection) the
arguments are attempted against each permitted form:
a clean match against exactly one form is
auto-selected (the result's 'form' key records it),
no match raises an error naming each candidate
form's failure, and matches against several forms
raise an error naming them - pass a single form to
disambiguate."
#default to enhanced errorstyle despite slow 'catch' (unhappy path) performance
#todo - configurable per interp/namespace
-errorstyle -type string -default enhanced -choices {enhanced standard basic minimal}
-caller -type string -default "" -help\
"Caller attribution for validation error messages.
When non-empty, this string replaces the %caller% placeholder in
validation failure messages instead of the automatic call-frame
walk - use it when parsing on behalf of another command (e.g a
usage/help display naming the queried command rather than the
internal parse call site)."
-cache -type boolean -default 0 -help\
{Use sparingly.
This caches the entire parse result or formatted validation error for the
same argument list, definition, and selected form.
It is a minor speedup suitable for functions that repeatedly parse a small
set of identical, generally small argument lists against a stable
definition.
Avoid it for one-off calls, large or highly variable argument lists, and
definitions whose dynamic substitutions must be re-evaluated on every call.
In particular, @dynamic definitions may still refresh their resolved
specification data internally, but -cache 1 can return a previously cached
parse result before those refreshed values affect the current call.}
@values -min 2
@form -form withid -synopsis "parse arglist ?-form {int|<formname>...}? ?-errorstyle <choice>? withid $id"
@values -max 2
withid -type literal(withid) -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(withdef) -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."
}]
variable parse_cache [dict create]
proc parse {args} {
#puts "punk::args::parse --> '$args'"
if {[llength $args] < 3} {
#error "punk::args::parse - invalid call. < 3 args"
punk::args::parse $args -cache 1 withid ::punk::args::parse
}
set opts_and_vals $args
set parseargs [lpop opts_and_vals 0]
set opts [list]
set values [list]
for {set i 0} {$i < [llength $opts_and_vals]} {incr i} {
if {[string match -* [lindex $opts_and_vals $i]]} {
if {[catch {
lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0]
}]} {
#unhappy path - not enough options
#review - which form of punk::args::parse?
#we expect this to always raise error - review
set result [punk::args::parse $args withid ::punk::args::parse]
puts stderr "punk::args::parse unexpected result $result"
return ;#failsafe
}
incr i -1
#lappend opts $a [lindex $opts_and_vals $i]
} else {
break
}
}
#set values [lrange $opts_and_vals $i end]
#set values $opts_and_vals
#puts "---values: $values"
#set tailtype [lindex $values 0] ;#withid|withdef
#set tailargs [lrange $values 1 end]
set tailtype [lpop opts_and_vals 0]
#Default the -errorstyle to standard
# (slow on unhappy path - but probably clearest for playing with new APIs interactively)
# - application devs should distribute a config file with an errorstyle override if desired.
# - devs who prefer a different default for interactive use should create a config for it. (todo)
set defaultopts [dict create {*}{
-form {*}
-errorstyle standard
-cache 0
-caller {}
}]
#todo - load override_errorstyle from configuration
#dict set defaultopts -errorstyle $
#puts "def: $defaultopts opts: $opts"
set opts [dict merge $defaultopts $opts]
dict for {k v} $opts {
switch -- $k {
-form - -errorstyle - -cache - -caller {
}
default {
#punk::args::usage $args withid ::punk::args::parse ??
#error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]"
punk::args::parse $args withid ::punk::args::parse
}
}
}
switch -- $tailtype {
withid {
#JJJ
set deflist [raw_def [lindex $opts_and_vals 0]]
if {[llength $deflist] == 0} {
if {[llength $opts_and_vals] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
set id [lindex $opts_and_vals 0]
error "punk::args::parse - no such id: $id"
}
}
withdef {
set deflist $opts_and_vals
if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
}
default {
error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'"
}
}
try {
#puts stdout "parse --> get_dict <deflist> $parseargs -form [dict get $opts -form]"
if {![dict get $opts -cache]} {
set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]]
} else {
variable parse_cache
set key [list $parseargs $deflist [dict get $opts -form] [dict get $opts -caller]]
if {[dict exists $parse_cache $key]} {
set cached [dict get $parse_cache $key]
if {[dict get $cached type] eq "result"} {
return [dict get $cached value]
} else {
#return the error 'elist'
return {*}[dict get $cached value]
}
} else {
set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]]
dict set parse_cache $key [dict create type "result" value $result]
return $result
}
}
} trap {PUNKARGS VALIDATION} {msg erroropts} {
set opt_errorstyle [dict get $opts -errorstyle]
set matched_errorstyle [tcl::prefix::match -error "" {enhanced standard basic minimal debug} $opt_errorstyle]
#samples from get_dict (review: -argspecs <dict> can be *large* especially for multi-form argument definitions)
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
set ecode [dict get $erroropts -errorcode]
#punk ecode is of form PUNKARGS VALIDATION {description..} -key val ...
if {[dict get $opts -caller] ne ""} {
#explicit caller attribution supplied (e.g punk::ns::cmdhelp usage display
#naming the queried command) - frame walking would name internal call sites.
set msg [string map [list %caller% [dict get $opts -caller]] $msg]
} else {
set msg [string map [list %caller% [Get_caller]] $msg]
}
#G-041: display-form selection for the usage render. For the multi-form
#candidacy failures the engine reports, show the candidate forms rather than
#the caller's (usually *) -form selection - best candidate first so its
#argument table renders (arg_error marks all listed forms in the synopsis).
set displayform [dict get $opts -form]
set classinfo [lindex $ecode 2]
switch -- [lindex $classinfo 0] {
noformmatch {
set failuredict [lrange $ecode 3 end]
if {[dict exists $failuredict -formerrors]} {
#ranked best-first at raise time (see rank_form_failures)
set displayform [dict keys [dict get $failuredict -formerrors]]
}
}
multipleformmatches {
set displayform [Dict_getdef [lrange $classinfo 1 end] forms $displayform]
}
}
switch -- $matched_errorstyle {
minimal {
#return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
}
basic {
#No table layout - unix manpage style
set customdict [lrange $ecode 3 end]
set argspecs [Dict_getdef $customdict -argspecs ""]
set badarg [Dict_getdef $customdict -badarg ""]
if {$argspecs ne ""} {
set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form $displayform]
}
#return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
}
standard {
set customdict [lrange $ecode 3 end]
set argspecs [Dict_getdef $customdict -argspecs ""]
set badarg [Dict_getdef $customdict -badarg ""]
if {$argspecs ne ""} {
set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form $displayform]
}
#return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
}
enhanced {
set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below)
set customdict [lrange $ecode 3 end]
set argspecs [Dict_getdef $customdict -argspecs ""]
set badarg [Dict_getdef $customdict -badarg ""]
set ecode_summary [lrange $ecode 0 2]
if {$badarg ne ""} {
lappend ecode_summary -badarg $badarg
}
catch {package require punk::lib}
if {[package provide punk::lib] ne ""} {
append msg \n [punk::lib::showdict -roottype list $estack */*]
}
if {$argspecs ne ""} {
set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form $displayform]
append msg \n "::errorCode summary: $ecode_summary"
#return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
} else {
#why? todo?
append msg \n "(enhanced error information unavailable)"
append msg \n "::errorCode summary: $ecode_summary"
#return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
}
}
debug {
puts stderr "errorstyle debug not implemented"
#return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
}
default {
puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug"
#return -options [list -code error -errorcode $ecode] $msg
set elist [list -options [list -code error -errorcode $ecode] $msg]
}
}
set key [list $parseargs $deflist [dict get $opts -form] [dict get $opts -caller]]
dict set parse_cache $key [dict create type "error" value $elist]
return {*}$elist
} trap {PUNKARGS} {msg erropts} {
append msg \n "Unexpected PUNKARGS error"
return -options [list -code error -errorcode $ecode] $msg
} trap {} {msg erroropts} {
#review
#quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw.
#If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple.
throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo]
}
return $result
}
#classify a PUNKARGS VALIDATION failure class-word into the parse-status overall status
#payload = elements of the errorcode description after the class word
proc private::parse_status_classify {failureclass payload} {
switch -- $failureclass {
missingrequiredleader - missingrequiredvalue - leadermissing - optionmissing - valuemissing - missingoptionvalue {
return incomplete
}
leadingvaluecount - trailingvaluecount {
#payload: <num> min <min> max <max>
set num [lindex $payload 0]
set min [Dict_getdef [lrange $payload 1 end] min ""]
if {[string is integer -strict $num] && [string is integer -strict $min] && $num < $min} {
return incomplete
}
return invalid
}
noformmatch {
#G-041 multi-form candidacy: payload is: forms <fids> classes <per-form statuses>
#incomplete when some candidate form needs only more words
if {"incomplete" in [Dict_getdef $payload classes {}]} {
return incomplete
}
return invalid
}
default {
return invalid
}
}
}
#build the parse-status structure documented in the ::punk::args::parse_status definition.
#fid selects the form whose argument set the per-argument statuses cover (the form usage
#displays render). Options are unvalidated internal inputs - see parse_status/arg_error.
proc private::parse_status_build {spec_dict fid args} {
set defaults [dict create {*}{
-ok ""
-status ""
-scheme ""
-message ""
-errorcode ""
-failureclass ""
-argfailureclass ""
-badarg ""
-parsedargs {}
-formstatus {}
}]
set opts [dict merge $defaults $args]
set parsedargs [dict get $opts -parsedargs]
set badarg [dict get $opts -badarg]
set form_dict [dict get $spec_dict FORMS $fid]
#map each member of an -alias1|-alias2|-realname optionset to the optionset (the ARG_INFO key)
set lookup_optset [dict create]
foreach optionset [dict get $form_dict OPT_NAMES] {
foreach o [split $optionset |] {
dict set lookup_optset $o $optionset
}
}
#received argument names normalized to definition argument names.
#received is dict-like but may repeat keys for -multiple arguments; values are clause ordinals.
set receivednames [list]
set positions [dict create] ;#argname -> list of clause ordinals
foreach {r rpos} [Dict_getdef $parsedargs received {}] {
if {[string match -* $r] && [dict exists $lookup_optset $r]} {
set r [dict get $lookup_optset $r]
}
if {$r ni $receivednames} {
lappend receivednames $r
}
dict lappend positions $r $rpos
}
if {$badarg ne "" && [string match -* $badarg] && [dict exists $lookup_optset $badarg]} {
set badarg [dict get $lookup_optset $badarg]
}
set parsed_leaders [Dict_getdef $parsedargs leaders {}]
set parsed_opts [Dict_getdef $parsedargs opts {}]
set parsed_values [Dict_getdef $parsedargs values {}]
set argstatus [dict create]
foreach {names class parsedvalues} [list {*}{
} [dict get $form_dict LEADER_NAMES] leader {*}{
} $parsed_leaders {*}{
} [dict get $form_dict OPT_NAMES] option {*}{
} $parsed_opts {*}{
} [dict get $form_dict VAL_NAMES] value {*}{
} $parsed_values {*}{
}] {
foreach arg $names {
set argpositions [Dict_getdef $positions $arg {}]
set received [llength $argpositions]
if {$arg eq $badarg} {
set status bad
#G-041: for the multi-form noformmatch failure the badarg belongs to the
#best-candidate form - its own failureclass (via -argfailureclass) is the
#accurate per-argument classification, the overall failureclass stays
#truthful to the errorcode
set argfailclass [dict get $opts -argfailureclass]
if {$argfailclass eq ""} {
set argfailclass [dict get $opts -failureclass]
}
} elseif {$received > 0} {
set status ok
set argfailclass ""
} else {
set status unparsed
set argfailclass ""
}
#value-in-effect (includes values the parse filled from -default).
#Direct lookup by definition argument name, matching the display renderers:
#aliased optionsets store under their canonical name and are not resolved here.
if {[dict exists $parsedvalues $arg]} {
set hasvalue 1
set value [dict get $parsedvalues $arg]
} else {
set hasvalue 0
set value ""
}
dict set argstatus $arg [dict create class $class status $status received $received positions $argpositions hasvalue $hasvalue value $value failureclass $argfailclass]
}
}
return [dict create {*}{
} ok [dict get $opts -ok] {*}{
} status [dict get $opts -status] {*}{
} scheme [dict get $opts -scheme] {*}{
} message [dict get $opts -message] {*}{
} errorcode [dict get $opts -errorcode] {*}{
} failureclass [dict get $opts -failureclass] {*}{
} badarg $badarg {*}{
} id [Dict_getdef $spec_dict id ""] {*}{
} form $fid {*}{
} formstatus [dict get $opts -formstatus] {*}{
} receivednames $receivednames {*}{
} argstatus $argstatus {*}{
}]
}
#G-041: resolve a -form selection to a list of form names.
#formselection is * (all forms) or a list whose elements are each an ordinal index or
#a form name (prefix-matchable). Supplied order is preserved (first element is the
#primary/display form for consumers that need a single form), duplicates removed.
#Raises an error naming $errprefix for an unrecognised element.
proc private::form_selection {form_names formselection {errprefix punk::args}} {
if {$formselection eq "*" || $formselection eq "" || "*" in $formselection} {
return $form_names
}
set selected [list]
foreach f $formselection {
if {[string is integer -strict $f]} {
if {$f < 0 || $f > [llength $form_names]-1} {
error "$errprefix invalid -form value '$f' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'"
}
set fid [lindex $form_names $f]
} else {
set fid [tcl::prefix::match -error "" $form_names $f]
if {$fid eq ""} {
error "$errprefix invalid -form value '$f' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'"
}
}
if {$fid ni $selected} {
lappend selected $fid
}
}
return $selected
}
#G-041: leading-literal affinity of a form for the supplied words - the ranking signal
#for candidate forms when no form parses cleanly (many multiform commands discriminate
#on a leading literal, e.g 'after cancel id').
#Walks the form's leading run of required single-member literal-typed arguments
#(leaders then values) against the corresponding words: +1 per agreement, and a large
#negative on the first disagreement (the form's discriminator word was not supplied).
#Heuristic for ranking/display only - candidacy itself always comes from real parse
#attempts. Known limits (recorded in G-041): no alignment through received options,
#choice-discriminated forms score 0.
proc private::form_literal_affinity {argspecs fid rawargs} {
set formdict [dict get $argspecs FORMS $fid]
set ARG_INFO [dict get $formdict ARG_INFO]
set score 0
set widx 0
foreach argname [list {*}[dict get $formdict LEADER_NAMES] {*}[dict get $formdict VAL_NAMES]] {
if {$widx >= [llength $rawargs]} {
break
}
if {[dict get $ARG_INFO $argname -optional]} {
break
}
set typelist [dict get $ARG_INFO $argname -type]
if {[llength $typelist] != 1} {
break
}
set tp [lindex $typelist 0]
if {[string match {\?*\?} $tp]} {
break
}
set word [lindex $rawargs $widx]
set is_literal 0
set word_matched 0
foreach alt [split $tp |] {
if {[string match {literal(*)} $alt]} {
set is_literal 1
if {$word eq [string range $alt 8 end-1]} {
set word_matched 1
break
}
} elseif {[string match {literalprefix(*)} $alt]} {
set is_literal 1
set lit [string range $alt 14 end-1]
if {$word ne "" && [string equal -length [string length $word] $word $lit]} {
set word_matched 1
break
}
}
}
if {!$is_literal} {
break
}
if {$word_matched} {
incr score
} else {
incr score -1000
break
}
incr widx
}
return $score
}
#G-041: order a formfailures dict (fid -> {status .. failureclass .. badarg .. message ..})
#best-candidate first: literal affinity desc, then incomplete before invalid, then the
#incoming (declaration) order. Returns the re-ordered dict.
proc private::rank_form_failures {argspecs rawargs formfailures} {
set scored [list]
dict for {fid finfo} $formfailures {
set negaffinity [expr {-[form_literal_affinity $argspecs $fid $rawargs]}]
set classrank [expr {[dict get $finfo status] eq "incomplete" ? 0 : 1}]
lappend scored [list $fid $negaffinity $classrank]
}
#lsort is stable - sort least significant key first
set scored [lsort -integer -index 2 $scored]
set scored [lsort -integer -index 1 $scored]
set ranked [dict create]
foreach entry $scored {
set fid [lindex $entry 0]
dict set ranked $fid [dict get $formfailures $fid]
}
return $ranked
}
lappend PUNKARGS [list {
@id -id ::punk::args::parse_status
@cmd -name punk::args::parse_status\
-summary\
"Parse-status structure from a parse attempt (validation failures reported, not raised)."\
-help\
"Run a parse attempt of arglist against a punk::args definition and
return a parse-status dict describing the outcome - for success AND
for validation failure (a validation failure is reported in the
returned structure instead of being raised as an error; other errors
such as an unknown id still raise).
This is the machine-parsable form of the information behind the
usage-display argument marking (punk::ns::cmdhelp / 'i <cmd> <args...>'):
which supplied arguments validated, which argument failed and why,
and which display scheme applies. punk::args::arg_error accepts the
structure via its -parsestatus option and derives its goodarg/badarg
row marking and choice value-in-effect highlighting from it.
Overall keys:
ok 1 parse succeeded, 0 validation failure
status valid | invalid | incomplete
invalid - a supplied word failed validation
incomplete - required arguments missing (a count or
allocation shortfall). Note a supplied word
failing its -type check can also surface as
an allocation shortfall (missingrequiredvalue)
- badarg and the per-argument statuses carry
the specifics in both situations.
scheme suggested display scheme: info (ok) | error (failure)
message empty | the validation failure message
errorcode empty | the -errorcode of the validation failure with
the bulky -argspecs payload removed
failureclass empty | first word of the errorcode description
(e.g choiceviolation, typemismatch, missingrequiredvalue)
badarg empty | name of the offending/unfillable argument
id the definition id
form form name the per-argument statuses were built for
(the form usage displays render). For multiform
definitions this is the parsed form when the parse
succeeded (auto-selected when -form permits several
- see punk::args::parse) and the best-candidate
form when no form matched (candidates ranked by
leading-literal affinity with the supplied words,
then incomplete before invalid, then declaration
order).
formstatus dict keyed by candidate form name - each value a
dict with at least the key 'status'
(valid | incomplete | invalid) and for failed
candidates failureclass, badarg and message.
Single-form parses report their one form; when
multi-form candidacy ran, every attempted form is
reported - partial-arglist consumers (e.g command
completion/hinting) can read per-form
compatibility from this key.
receivednames received argument names normalized to definition
argument names (opt aliases folded to their
-alias|-name optionset)
argstatus dict keyed by definition argument name, each value a
dict with keys:
class leader | option | value
status ok (received and validated) |
bad (the offending argument) |
unparsed (not received)
received count of received clauses (0 if unreceived)
positions ordinal positions of received clauses
hasvalue 1 if a value-in-effect is known
value value-in-effect - includes values the
parse filled from -default; empty when
hasvalue is 0. No values are reported
for a failed parse.
"
@form -form {withid withdef}
@leaders -min 1 -max 1
arglist -type list -optional 0 -help\
"Arguments to parse - supplied as a single list"
@opts -prefix 0
-form -type list -default * -help\
"Restrict parsing to the set of forms listed (see punk::args::parse).
The per-argument statuses are built for the first matching form."
-caller -type string -default "" -help\
"Caller attribution for the validation failure message
(see punk::args::parse -caller). When empty, defaults to the
definition's @cmd -name (or its id) rather than the call-frame
walk parse would perform."
@values -min 2
@form -form withid -synopsis "parse_status arglist ?-form {int|<formname>...}? ?-caller <string>? withid $id"
@values -max 2
withid -type literal(withid) -help\
"The literal value 'withid'"
id -type string -help\
"id of punk::args definition for a command"
@form -form withdef -synopsis "parse_status arglist ?-form {int|<formname>...}? ?-caller <string>? withdef $def ?$def?"
withdef -type literal(withdef) -help\
"The literal value 'withdef'"
def -type string -multiple 1 -optional 0 -help\
"Each remaining argument is a block of text
defining argument definitions."
}]
proc parse_status {args} {
if {[llength $args] < 3} {
punk::args::parse $args withid ::punk::args::parse_status
}
set opts_and_vals $args
set arglist [lpop opts_and_vals 0]
set opts [dict create {*}{
-form {*}
-caller {}
}]
while {[llength $opts_and_vals] && [string match -* [lindex $opts_and_vals 0]]} {
set k [lpop opts_and_vals 0]
switch -- $k {
-form - -caller {
if {![llength $opts_and_vals]} {
punk::args::parse $args withid ::punk::args::parse_status
}
dict set opts $k [lpop opts_and_vals 0]
}
default {
punk::args::parse $args withid ::punk::args::parse_status
}
}
}
set tailtype [lpop opts_and_vals 0]
switch -- $tailtype {
withid {
if {[llength $opts_and_vals] != 1} {
punk::args::parse $args withid ::punk::args::parse_status
}
set id [lindex $opts_and_vals 0]
set spec_dict [get_spec $id]
if {$spec_dict eq ""} {
error "punk::args::parse_status - no such id: $id"
}
}
withdef {
if {[llength $opts_and_vals] < 1} {
punk::args::parse $args withid ::punk::args::parse_status
}
set spec_dict [resolve {*}$opts_and_vals]
}
default {
punk::args::parse $args withid ::punk::args::parse_status
}
}
#G-041: primary form of the caller's -form selection - the fallback display form
#when the parse outcome doesn't identify a better one (an invalid -form value is
#left to the parse call below to raise consistently)
if {[catch {private::form_selection [dict get $spec_dict form_names] [dict get $opts -form]} selected_forms]} {
set selected_forms [dict get $spec_dict form_names]
}
set fid [lindex $selected_forms 0]
set caller [dict get $opts -caller]
if {$caller eq ""} {
#the frame walk parse would do by default names parse_status's own internal
#parse call - the definition's command name is the meaningful attribution here
set caller [Dict_getdef $spec_dict cmd_info -name [Dict_getdef $spec_dict id ""]]
}
if {[catch {
punk::args::parse $arglist -form [dict get $opts -form] -errorstyle minimal -caller $caller $tailtype {*}$opts_and_vals
} r ropts]} {
set ecode [Dict_getdef $ropts -errorcode ""]
if {[lrange $ecode 0 1] ne [list PUNKARGS VALIDATION]} {
#not an argument validation failure (e.g definition error) - propagate
return -options $ropts $r
}
set classinfo [lindex $ecode 2]
set failureclass [lindex $classinfo 0]
set payload [lrange $classinfo 1 end]
set customdict [lrange $ecode 3 end]
set badarg [Dict_getdef $customdict -badarg ""]
set status [private::parse_status_classify $failureclass $payload]
#G-041 multi-form candidacy failures: the per-argument statuses are built for
#the best-candidate form (ranked at raise time), with its badarg and its own
#failureclass for the argument marking; formstatus carries every candidate.
set argfailureclass ""
set formstatus [dict create]
switch -- $failureclass {
noformmatch {
set formerrors [Dict_getdef $customdict -formerrors {}]
if {[dict size $formerrors]} {
set fid [lindex [dict keys $formerrors] 0]
set bestinfo [dict get $formerrors $fid]
set badarg [dict get $bestinfo badarg]
set argfailureclass [dict get $bestinfo failureclass]
set formstatus $formerrors
}
}
multipleformmatches {
set matchedforms [Dict_getdef $payload forms {}]
if {[llength $matchedforms]} {
set fid [lindex $matchedforms 0]
foreach mf $matchedforms {
dict set formstatus $mf [dict create status valid]
}
}
}
default {
set formstatus [dict create $fid [dict create status $status failureclass $failureclass badarg $badarg message $r]]
}
}
#the -argspecs payload (the whole resolved spec) is display machinery - too bulky
#for a status structure; keep the classification and the small custom keys
set ecode_slim [lrange $ecode 0 2]
foreach {k v} $customdict {
if {$k ne "-argspecs"} {
lappend ecode_slim $k $v
}
}
#engine-level per-form failure messages retain the %caller% placeholder -
#apply the same attribution the overall message received
dict for {ffid finfo} $formstatus {
if {[dict exists $finfo message]} {
dict set formstatus $ffid message [string map [list %caller% $caller] [dict get $finfo message]]
}
}
return [private::parse_status_build $spec_dict $fid -ok 0 -status $status -scheme error -message $r -errorcode $ecode_slim -failureclass $failureclass -argfailureclass $argfailureclass -badarg $badarg -formstatus $formstatus]
}
#success - the parse result identifies the parsed form (auto-selected for
#multiform definitions - G-041) and, when candidacy ran, every candidate's status
set fid [Dict_getdef $r form $fid]
set formstatus [Dict_getdef $r formstatus [dict create $fid [dict create status valid]]]
#engine-level per-form failure messages retain the %caller% placeholder
dict for {ffid finfo} $formstatus {
if {[dict exists $finfo message]} {
dict set formstatus $ffid message [string map [list %caller% $caller] [dict get $finfo message]]
}
}
return [private::parse_status_build $spec_dict $fid -ok 1 -status valid -scheme info -parsedargs $r -formstatus $formstatus]
}
#return number of values we can assign to cater for variable length clauses such as:
# {"elseif" expr "?then?" body}
#review - efficiency? each time we call this - we are looking ahead at the same info
proc private::get_dict_can_assign_value {idx values nameidx names namesreceived formdict} {
set ARG_INFO [dict get $formdict ARG_INFO]
set all_remaining [lrange $values $idx end]
set thisname [lindex $names $nameidx]
set thistype [dict get $ARG_INFO $thisname -type]
set tailnames [lrange $names $nameidx+1 end]
#todo - work backwards with any (optional or not) literals at tail that match our values - and remove from assignability.
set ridx 0
#puts "-=============- thisname:'$thisname' thistype:'$thistype' tailnames:'$tailnames' all_remaining:'$all_remaining' [info level -2]"
foreach clausename [lreverse $tailnames] {
#puts "=============== thisname:'$thisname' thistype:'$thistype' clausename:'$clausename' all_remaining:'$all_remaining'"
set clause_is_multiple [dict get $ARG_INFO $clausename -multiple]
set clause_is_optional [dict get $ARG_INFO $clausename -optional]
set typelist [dict get $ARG_INFO $clausename -type]
#---------------
#review - not quite right to look for literal* in typelist
#- we should be looking for any type-alternate that starts with literal( or literalprefix(
#- but for now we require the whole type to be literal* if it's a literal match type.
# We should probably also support stringstartswith(*) and stringendswith(*) too.
#also consider that -choices {abc def} is effectively a literal match type too - we should support that here as well.
if {[lsearch $typelist literal*] == -1} {
break
}
#---------------
set max_clause_length [llength $typelist]
if {$max_clause_length == 1} {
#basic case
set alloc_ok 0
#set v [lindex $values end-$ridx]
set v [lindex $all_remaining end]
set tp [lindex $typelist 0]
# -----------------
set tp [string trim $tp ?] ;#shouldn't be necessary
#review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead?
#we shouldn't have an optional clause member if there is only one member - the whole argument should be marked -optional true instead.
# -----------------
#todo - support complex type members such as -type {{literal a|b} int OR}
#for now - require llength 1 - simple type such as -type {literal(ab)|int}
if {[llength $tp] !=1} {
error "private::get_dict_can_assign_value: complex -type not yet supported (tp:'$tp')"
}
#foreach tp_alternative [split $tp |] {}
set tp_alternatives [private::split_type_expression $tp]
foreach tp_alternative $tp_alternatives {
switch -exact -- [lindex $tp_alternative 0] {
literal {
set match [lindex $tp_alternative 1] ;#was bracketed part if of form literal(xxx)
if {$v eq $match} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
#the type (or one of the possible type alternates) matched a literal
break
}
}
literalprefix {
set prefix_of [lindex $tp_alternative 1]
#get list of literal and literalprefix values in the current list of tp_alternatives so we can construct list of alternatives for tcl::prefix::match prefix calculation.
#todo - consider if this clause also has -choices {abc def} - we should support those as well here as literal matches for the purposes of calculating the prefix match.
# (this is somewhat of an edge case but sometimes it's useful to specify a -type when -choices is used with -choicerestricted false, to allow only specific values not in the choices list.)
set comparelist [list]
foreach alt $tp_alternatives {
switch -exact -- [lindex $alt 0] {
literal - literalprefix {
lappend comparelist [lindex $alt 1]
}
}
}
set fullmatch [tcl::prefix::match -error "" $comparelist $v]
if {$fullmatch eq $prefix_of} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
break
}
}
stringstartswith {
set pfx [lindex $tp_alternative 1]
if {[string match "$pfx*" $v]} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
break
}
}
stringendswith {
set sfx [lindex $tp_alternative 1]
if {[string match "*$sfx" $v]} {
set alloc_ok 1
ledit all_remaining end end
if {!$clause_is_multiple} {
ledit tailnames end end
}
break
}
}
default {}
}
}
if {!$alloc_ok} {
if {!$clause_is_optional} {
break
}
}
} else {
#todo - use private::split_type_expression
#review - we assume here that we don't have a set of clause-members where all are marked optional (?membertype?)
#This is better caught during definition.
#e.g rn = {elseif expr (?then?) body} typelist = {literal expr ?literal? script}
#set cvals [lrange $values end-$ridx end-[expr {$ridx + $max_clause_length-1}]]
set cvals [lrange $values end-[expr {$ridx + $max_clause_length-1}] end-$ridx]
set rcvals [lreverse $cvals]
set alloc_count 0
#clause name may have more entries than types - extras at beginning are ignored
set rtypelist [lreverse $typelist]
set alloc_ok 0
set reverse_type_index 0
#todo handle type-alternates
# for example: -type {string literal(x)|literal(y)}
# -type {string literal(max)|literal(min)|int}
foreach tp $rtypelist {
#set rv [lindex $rcvals end-$alloc_count]
set rv [lindex $all_remaining end-$alloc_count]
if {[string match {\?*\?} $tp]} {
set clause_member_optional 1
} else {
set clause_member_optional 0
}
set tp [string trim $tp ?]
#puts "private::get_dict_can_assign_value: checking tp '$tp' against value '$rv'"
switch -glob -- $tp {
"literal(*" {
set litmatch [string range $tp 8 end-1]
if {$rv eq $litmatch} {
set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok
incr alloc_count
} else {
if {$clause_member_optional} {
#
} else {
set alloc_ok 0
break
}
}
}
XXXliteral* {
#JJJ
set litinfo [string range $tp 7 end]
set match [string range $litinfo 1 end-1]
#todo -literalprefix
if {$rv eq $match} {
set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok
incr alloc_count
} else {
if {$clause_member_optional} {
#
} else {
set alloc_ok 0
break
}
}
}
"stringstartswith(*" {
set pfx [string range $tp 17 end-1]
if {[string match "$pfx*" $tp]} {
set alloc_ok 1
incr alloc_count
} else {
if {!$clause_member_optional} {
set alloc_ok 0
break
}
}
}
default {
if {$clause_member_optional} {
#review - optional non-literal makes things harder..
#we don't want to do full type checking here - but we now risk allocating an item that should actually
#be allocated to the previous value
# todo - lsearch to next literal or non-optional?
set prev_type [lindex $rtypelist $reverse_type_index+1]
if {[string match literal* $prev_type]} {
set litinfo [string range $prev_type 7 end]
#todo -literalprefix
if {[string match (*) $litinfo]} {
set match [string range $litinfo 1 end-1]
} else {
set match [lindex $rclausename $reverse_type_index+1]
}
if {$rv ne $match} {
#current val doesn't match previous type - allocate here
incr alloc_count
}
} else {
#no literal to anchor against..
incr alloc_count
}
} else {
#allocate regardless of type - we're only matching on arity and literal positioning here.
#leave final type-checking for later.
incr alloc_count
}
}
}
incr reverse_type_index
}
if {$alloc_ok && $alloc_count > 0} {
#set n [expr {$alloc_count -1}]
#set all_remaining [lrange $all_remaining end-$n end]
set all_remaining [lrange $all_remaining 0 end-$alloc_count]
#don't lpop if -multiple true
if {!$clause_is_multiple} {
#lpop tailnames
ledit tailnames end end
}
} else {
break
}
}
incr ridx
}
set num_remaining [llength $all_remaining]
if {[dict get $ARG_INFO $thisname -optional] || ([dict get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived)} {
#todo - check -multiple for required min/max (not implemented: make -multiple accept <int|range> ?)
#thisname already satisfied, or not required
set tail_needs 0
foreach t $tailnames {
if {![dict get $ARG_INFO $t -optional]} {
set min_clause_length [llength [lsearch -all -not [dict get $ARG_INFO $t -type] {\?*\?}]]
incr tail_needs $min_clause_length
}
}
set all_remaining [lrange $all_remaining 0 end-$tail_needs]
}
#thistype
set alloc_ok 1 ;#default assumption only
set alloc_count 0
set resultlist [list]
set n [expr {[llength $thistype]-1}]
set tpidx 0
set newtypelist $thistype
set has_choices [expr {[tcl::dict::exists $ARG_INFO $thisname -choices] || [tcl::dict::exists $ARG_INFO $thisname -choicegroups]}]
set choicescreen_applies 0
if {$has_choices} {
#G-071: with a restricted choice set (the default) allocation SCREENS the
#candidate word against the choices rather than blanket-accepting - but
#ONLY where allocation has an alternative: optional arguments (and extra
#occurrences of -multiple arguments). Previously any word was consumed
#here whenever arity permitted, so an optional choice value (e.g the lseq
#'..'/'to' noise word) greedily took a word that belonged to later
#elements/clauses and the parse failed with a confusing trailing-choices
#error ('lseq 0 10 2' shape). The screen uses choiceword_match - the
#shared G-040 implementation - so allocation acceptance cannot diverge
#from parse acceptance (exact/alias/prefix/nocase semantics included);
#-choicemultiple words are screened per list member. For a REQUIRED
#argument the word must fill it regardless - rejecting here would only
#mask final validation's informative choiceviolation as a
#missingrequired* error, so required arguments are not screened.
#Final validation remains authoritative; the screen compares raw words
#(no ansistrip) - an ansi-wrapped choice word on an optional argument
#would be skipped here where validation would accept it (accepted edge -
#allocation errs toward yielding words onward). With -choicerestricted 0
#any word remains allocatable (each tp in the clause then only validates
#values outside the choice-list).
if {[Dict_getdef $ARG_INFO $thisname -choicerestricted 1]
&& ([tcl::dict::get $ARG_INFO $thisname -optional]
|| ([tcl::dict::get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived))} {
set choicescreen_applies 1
set cw_allchoices [list]
if {[tcl::dict::exists $ARG_INFO $thisname -choices]} {
set cw_allchoices [tcl::dict::get $ARG_INFO $thisname -choices]
}
if {[tcl::dict::exists $ARG_INFO $thisname -choicegroups]} {
tcl::dict::for {_grp grpmembers} [tcl::dict::get $ARG_INFO $thisname -choicegroups] {
lappend cw_allchoices {*}$grpmembers
}
}
set cw_nocase [Dict_getdef $ARG_INFO $thisname -nocase 0]
set cw_prefix [Dict_getdef $ARG_INFO $thisname -choiceprefix 1]
set cw_aliases [Dict_getdef $ARG_INFO $thisname -choicealiases {}]
set cw_deny [Dict_getdef $ARG_INFO $thisname -choiceprefixdenylist {}]
set cw_reserve [Dict_getdef $ARG_INFO $thisname -choiceprefixreservelist {}]
lassign [Dict_getdef $ARG_INFO $thisname -choicemultiple {1 1}] cw_cmmin cw_cmmax
}
}
foreach tp $thistype {
#usual case is a single tp (basic length-1 clause) - but tp may commonly have alternates eg int|literal(xxx)
set v [lindex $all_remaining $alloc_count]
if {[string match {\?*\?} $tp]} {
set clause_member_optional 1
} else {
set clause_member_optional 0
}
set tp [string trim $tp ?]
set member_satisfied 0
set member_choicechecked 0
if {$has_choices} {
if {$choicescreen_applies} {
#G-071 allocation screen (see block above the loop)
set member_choicechecked 1
if {$cw_cmmax == 1} {
set cwm [choiceword_match $v $cw_nocase $cw_allchoices $cw_aliases $cw_prefix $cw_deny $cw_reserve]
set member_satisfied [tcl::dict::get $cwm matched]
} else {
#-choicemultiple: the word is itself a list of choices - screen
#each member; count within the declared min/max (max -1 = no limit)
if {[catch {llength $v} v_len]} {
set member_satisfied 0
} elseif {$v_len < $cw_cmmin || ($cw_cmmax > 0 && $v_len > $cw_cmmax)} {
set member_satisfied 0
} else {
set member_satisfied 1
foreach v_member $v {
set cwm [choiceword_match $v_member $cw_nocase $cw_allchoices $cw_aliases $cw_prefix $cw_deny $cw_reserve]
if {![tcl::dict::get $cwm matched]} {
set member_satisfied 0
break
}
}
}
}
} else {
#required argument with restricted choices (word must fill it -
#validation reports choice violations), or -choicerestricted 0
#(each tp in the clause only validates values outside the
#choice-list)
set member_satisfied 1
}
}
#category lists must exist even when the choice screen decided the member
#(the !member_satisfied blocks below consult their lengths)
set ctg_literals [list]
set ctg_literalprefixes [list]
set ctg_stringstartswith [list]
set ctg_stringendswith [list]
set ctg_other [list]
if {!$member_satisfied && !$member_choicechecked} {
#-----------------------------------------------------------------------------------
#first build category lists of any literal,literalprefix,stringstartwith,other
#
#foreach tp_alternative [split $tp |] {}
foreach tp_alternative [private::split_type_expression $tp] {
#JJJJ
lassign $tp_alternative t textra
switch -exact -- $t {
literal {
lappend ctg_literals $textra
}
literalprefix {
lappend ctg_literalprefixes $textra
}
stringstartswith {
lappend ctg_stringstartswith $textra
}
stringendswith {
lappend ctg_stringendswith $textra
}
default {
lappend ctg_other $tp_alternative
}
}
}
#-----------------------------------------------------------------------------------
if {[llength $ctg_other] > 0} {
#presence of any ordinary type as one of the alternates - means we consider it a match if certain basic types align
#we don't do full validation here -leave main validation for later (review)
foreach tp_alternative $ctg_other {
switch -exact -- $tp_alternative {
int {
if {[string is integer -strict $v]} {
set member_satisfied 1
break
}
}
double {
if {[string is double -strict $v]} {
set member_satisfied 1
break
}
}
bool {
if {[string is boolean -strict $v]} {
set member_satisfied 1
break
}
}
number {
if {[string is integer -strict $v] || [string is double -strict $v]} {
set member_satisfied 1
break
}
}
dict {
if {[punk::args::lib::string_is_dict $v]} {
set member_satisfied 1
break
}
}
default {
#REVIEW!!!
#can get infinite loop in get_dict if not satisfied - unstoppable until memory exhausted.
#todo - catch/detect in caller
set member_satisfied 1
break
}
}
}
}
}
if {!$member_satisfied && ([llength $ctg_literals] || [llength $ctg_literalprefixes])} {
if {$v in $ctg_literals} {
set member_satisfied 1
lset newtypelist $tpidx validated-$tp
} else {
#ctg_literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed
#(exact match would have been caught in other branch of this if)
#review - how does ctg_stringstartswith affect prefix calc for literals?
set full_v [tcl::prefix::match -error "" [list {*}$ctg_literals {*}$ctg_literalprefixes] $v]
if {$full_v ne "" && $full_v ni $ctg_literals} {
#matched prefix must be for one of the entries in ctg_literalprefixes - valid
set member_satisfied 1
set v $full_v ;#map prefix given as arg to the full literalprefix value
lset newtypelist $tpidx validated-$tp
}
}
}
if {!$member_satisfied && [llength $ctg_stringstartswith]} {
foreach pfx $ctg_stringstartswith {
if {[string match "$pfx*" $v]} {
set member_satisfied 1
lset newtypelist $tpidx validated-$tp
#review. consider multi-word typespec with RPN?
# {*}$tp_alternative validated
break
}
}
}
if {!$member_satisfied && [llength $ctg_stringendswith]} {
foreach pfx $ctg_stringendswith {
if {[string match "*$pfx" $v]} {
set member_satisfied 1
lset newtypelist $tpidx validated-$tp
break
}
}
}
if {$member_satisfied} {
if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} {
if {[dict exists $ARG_INFO $thisname -typedefaults]} {
set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx]
lappend resultlist $d
lset newtypelist $tpidx ?defaulted-$tp?
} else {
lset newtypelist $tpidx ?omitted-$tp?
lappend resultlist ""
}
} else {
#may have satisfied one of the basic type tests above
lappend resultlist $v
incr alloc_count
}
} else {
if {$clause_member_optional} {
if {[dict exists $ARG_INFO $thisname -typedefaults]} {
set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx]
lappend resultlist $d
lset newtypelist $tpidx ?defaulted-$tp?
} else {
lappend resultlist ""
lset newtypelist $tpidx ?omitted-$tp?
}
} else {
set alloc_ok 0
}
}
if {$alloc_count > [llength $all_remaining]} {
set alloc_ok 0
break
}
incr tpidx
}
#?omitted-*? and ?defaulted-*? in typelist are a way to know which elements in the clause were missing/defaulted
#so that they are not subject to type validation
#such elements shouldn't be subject to validation
if {$alloc_ok} {
#puts stderr ">>>private::get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype"
set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist]
} else {
#puts stderr ">>>private::get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype"
set d [dict create consumed 0 resultlist {} typelist $thistype]
}
#puts ">>>> private::get_dict_can_assign_value $d"
return $d
}
#private::split_type_expression
#only handles toplevel 'or' for type_expression e.g int|char
#we have no mechanism for & - (although it would be useful)
#more complex type_expressions would require a bracketing syntax - (and probably pre-parsing)
#or perhaps more performant, RPN to avoid bracket parsing
#if literal(..), literalprefix(..), stringstartswith(..) etc can have pipe symbols and brackets etc - we can't just use split
#if we require -type to always be treated as a list - and if an element is length 1 - require it to
#have properly balanced brackets that don't contain | ( ) etc we can simplify - REVIEW
#consider:
#1 basic syntax - only OR supported - limits on what chars can be put in 'textn' elements.
#mode -type literalprefix(text1)|literalprefix(text2) -optional 1
#2 expanded syntax - supports arbitrary chars in 'textn' elements - but still doesn't support more complex OR/AND logic
#mode -type {{literalprefix text1 | literalprefix text2}}
#3 RPN (reverse polish notation) - somewhat unintuitive, but allows arbitrary textn, and complex OR/AND logic without brackets.
#(forth like - stack based definition of types)
#mode -type {literalprefix text1 literalprefix text2 OR}
#mode -type {stringstartswith x stringstartswith y OR stringendswith z AND int OR}
proc private::split_type_expression {type_expression} {
if {[llength $type_expression] == 1} {
#simple expressions of length one must be splittable on |
#disallowed: things such as literal(|) or literal(x|etc)|int
#these would have to be expressed as {literal |} and {literal x|etc | int}
set or_type_parts [split $type_expression |]
set type_alternatives [list]
foreach t $or_type_parts {
if {[regexp {([^\(^\)]*)\((.*)\)$} $t _ name val]} {
lappend type_alternatives [list $name $val]
} else {
lappend type_alternatives $t
}
}
return $type_alternatives
} else {
error "private::split_type_expression unimplemented: type_expression length > 1 '$type_expression'"
#todo
#RPN reverse polish notation
#e.g {stringstartswith x stringstartswith y OR stringendswith z AND int OR}
#equivalent logic: ((stringstartswith(x)|stringstartswith(y))&stringendswith(z))|int
# {int ; stringstartswith x stringstartswith y OR }
#experimental.. seems like a pointless syntax.
#may as well just use list of lists with |(or) as the intrinsic operator instead of parsing this
#e.g {stringstartswith x | literal | | int}
set type_alternatives [list]
set expect_separator 0
for {set w 0} {$w < [llength $type_expression]} {incr w} {
set word [lindex $type_expression $w]
if {$expect_separator} {
if {$word eq "|"} {
#pipe could be last entry - not strictly correct, but can ignore
set expect_separator 0
continue
} else {
error "private::split_type_expression expected separator but received '$word' in type_expression:'$type_expression'"
}
}
switch -exact -- $word {
literal - literalprefix - stringstartswith - stringendswith - stringcontains {
if {$w+1 > [llength $type_expression]} {
#premature end - no arg available for type which requires one
error "private::split_type_expression missing argument for type '$word' in type_expression:'$type_expression'"
}
lappend type_alternatives [list $word [lindex $type_expression $w+1]]
incr w ;#consume arg
set expect_separator 1
}
default {
#simple types such as int,double,string
lappend type_alternatives $word
set expect_separator 1
}
}
}
return $type_alternatives
}
}
#old version
###proc private::check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn type_expression clausevalues_raw clausevalues_check argspecs} {
### #set type $type_expression ;#todo - 'split' on |
### set vlist $clausevalues_raw
### set vlist_check $clausevalues_check
### set type_alternatives [private::split_type_expression $type_expression]
### #each type_alternative is a list of varying length depending on arguments supported by first word.
### #TODO?
### #single element types: int double string etc
### #two element types literal literalprefix stringstartswith stringendswith
### #TODO
### set stype [lindex $type_alternatives 0]
### #e.g int
### #e.g {literal blah)etc}
### set type [lindex $stype 0]
### #switch on first word of each stype
### #
### #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ?
### switch -- $type {
### any {}
### literal {
### foreach clauseval $vlist {
### set e [lindex $clauseval $clausecolumn]
### set testval [lindex $stype 1]
### if {$e ne $testval} {
### set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg
### }
### }
### }
### stringstartwith {
### foreach clauseval $vlist {
### set e [lindex $clauseval $clausecolumn]
### set testval [lindex $stype 1]
### if {![string match $testval* $e]} {
### set msg "$argclass '$argname' for %caller% requires stringstartswith value '$argname'. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg
### }
### }
### }
### list {
### foreach clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {![tcl::string::is list -strict $e_check]} {
### set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg
### }
### if {[tcl::dict::size $thisarg_checks]} {
### tcl::dict::for {checkopt checkval} $thisarg_checks {
### switch -- $checkopt {
### -minsize {
### # -1 for disable is as good as zero
### if {[llength $e_check] < $checkval} {
### set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg
### }
### }
### -maxsize {
### if {$checkval ne "-1"} {
### if {[llength $e_check] > $checkval} {
### set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg
### }
### }
### }
### }
### }
### }
### }
### }
### indexexpression {
### foreach clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {[catch {lindex {} $e_check}]} {
### set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### string - ansistring - globstring {
### #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string
### #we possibly don't want to always have to regex on things that don't pass the other more basic checks
### # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations)
### # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform)
### # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead
### # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function
### # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform)
### # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail
### #todo? - way to validate both unstripped and stripped?
### set pass_quick_list_e [list]
### set pass_quick_list_e_check [list]
### set remaining_e $vlist
### set remaining_e_check $vlist_check
### #review - order of -regexprepass and -regexprefail in original rawargs significant?
### #for now -regexprepass always takes precedence
### set regexprepass [tcl::dict::get $thisarg -regexprepass]
### set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9
### if {$regexprepass ne ""} {
### foreach clauseval $vlist clauseval_check $vlist_check {
### set e [lindex $clauseval $clausecolumn]
### set e_check [lindex $clauseval_check $clausecolumn]
### if {[regexp [lindex $regexprepass $clausecolumn] $e]} {
### lappend pass_quick_list_e $clauseval
### lappend pass_quick_list_e_check $clauseval_check
### }
### }
### set remaining_e [punklib_ldiff $vlist $pass_quick_list_e]
### set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check]
### }
### if {$regexprefail ne ""} {
### foreach clauseval $remaining_e clauseval_check $remaining_e_check {
### set e [lindex $clauseval $clausecolumn]
### set e_check [lindex $clauseval_check $clausecolumn]
### #puts "----> checking $e vs regex $regexprefail"
### if {[regexp $regexprefail $e]} {
### if {[tcl::dict::exists $thisarg -regexprefailmsg]} {
### #review - %caller% ??
### set msg [tcl::dict::get $thisarg -regexprefailmsg]
### } else {
### set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'"
### }
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### switch -- $type {
### ansistring {
### #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi
### #.. so we need to look at the original values in $vlist not $vlist_check
### #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only??
### #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ???
### package require punk::ansi
### foreach clauseval $remaining_e {
### set e [lindex $clauseval $clausecolumn]
### if {![punk::ansi::ta::detect $e]} {
### set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### globstring {
### foreach clauseval $remaining_e {
### set e [lindex $clauseval $clausecolumn]
### if {![regexp {[*?\[\]]} $e]} {
### set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### }
### if {[tcl::dict::size $thisarg_checks]} {
### foreach clauseval $remaining_e_check {
### set e_check [lindex $clauseval $clausecolumn]
### if {[dict exists $thisarg_checks -minsize]} {
### set minsize [dict get $thisarg_checks -minsize]
### # -1 for disable is as good as zero
### if {[tcl::string::length $e_check] < $minsize} {
### set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### if {[dict exists $thisarg_checks -maxsize]} {
### set maxsize [dict get $thisarg_checks -maxsize]
### if {$checkval ne "-1"} {
### if {[tcl::string::length $e_check] > $maxsize} {
### set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### }
### }
### }
### number {
### #review - consider effects of Nan and Inf
### #NaN can be considered as 'technically' a number (or at least a special numeric value)
### foreach clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} {
### set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### if {[tcl::dict::exists $thisarg -typeranges]} {
### set ranges [tcl::dict::get $thisarg -typeranges]
### foreach clauseval $vlist clauseval_check $vlist_check {
### set e [lindex $clauseval $clausecolumn]
### set e_check [lindex $clauseval_check $clausecolumn]
### set range [lindex $ranges $clausecolumn]
### lassign {} low high ;#set both empty
### lassign $range low high
### if {"$low$high" ne ""} {
### if {[::tcl::mathfunc::isnan $e]} {
### set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### if {$low eq ""} {
### if {$e_check > $high} {
### set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### } elseif {$high eq ""} {
### if {$e_check < $low} {
### set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### } else {
### if {$e_check < $low || $e_check > $high} {
### set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### }
### }
### }
### int {
### #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive
### foreach clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {![tcl::string::is integer -strict $e_check]} {
### set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### if {[tcl::dict::exists $thisarg -typeranges]} {
### set ranges [tcl::dict::get $thisarg -typeranges]
### foreach clauseval $vlist clauseval_check $vlist_check {
### set e [lindex $clauseval $clausecolumn]
### set e_check [lindex $clauseval_check $clausecolumn]
### set range [lindex $ranges $clausecolumn]
### lassign $range low high
### if {"$low$high" ne ""} {
### if {$low eq ""} {
### #lowside unspecified - check only high
### if {$e_check > $high} {
### set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### } elseif {$high eq ""} {
### #highside unspecified - check only low
### if {$e_check < $low} {
### set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### } else {
### #high and low specified
### if {$e_check < $low || $e_check > $high} {
### set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### }
### }
### }
### double {
### foreach clauseval $vlist clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {![tcl::string::is double -strict $e_check]} {
### set e [lindex $clauseval $clausecolumn]
### set msg "$argclass $argname for %caller% requires type double. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### if {[tcl::dict::size $thisarg_checks]} {
### if {[dict exists $thisarg_checks -typeranges]} {
### set ranges [dict get $thisarg_checks -typeranges]
### foreach clauseval $vlist clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### set range [lindex $ranges $clausecolumn]
### #todo - small-value double comparisons with error-margin? review
### #todo - empty string for low or high
### lassign $range low high
### if {$e_check < $low || $e_check > $high} {
### set e [lindex $clauseval $clausecolumn]
### set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### }
### }
### bool {
### foreach clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {![tcl::string::is boolean -strict $e_check]} {
### set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### dict {
### foreach clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {[llength $e_check] %2 != 0} {
### set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg
### }
### }
### if {[tcl::dict::size $thisarg_checks]} {
### if {[dict exists $thisarg_checks -minsize]} {
### set minsizes [dict get $thisarg_checks -minsize]
### foreach clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### set minsize [lindex $minsizes $clausecolumn]
### # -1 for disable is as good as zero
### if {[tcl::dict::size $e_check] < $minsize} {
### set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg
### }
### }
### }
### if {[dict exists $thisarg_checks -maxsize]} {
### set maxsizes [dict get $thisarg_checks -maxsize]
### foreach clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### set maxsize [lindex $maxsizes $clausecolumn]
### if {$maxsize ne "-1"} {
### if {[tcl::dict::size $e_check] > $maxsize} {
### set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg
### }
### }
### }
### }
### }
### }
### alnum -
### alpha -
### ascii -
### control -
### digit -
### graph -
### lower -
### print -
### punct -
### space -
### upper -
### wordchar -
### xdigit {
### foreach clauseval $vlist clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {![tcl::string::is $type -strict $e_check]} {
### set e [lindex $clauseval $t]
### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### }
### }
### file -
### directory -
### existingfile -
### existingdirectory {
### foreach clauseval $vlist clauseval_check $vlist_check {
### set e [lindex $clauseval $clausecolumn]
### set e_check [lindex $clauseval_check $clausecolumn]
### #//review - we may need '?' char on windows
### if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>]} $e_check])} {
### #what about special file names e.g on windows NUL ?
### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
### }
### if {$type eq "existingfile"} {
### if {![file exists $e_check]} {
### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg
### }
### } elseif {$type eq "existingdirectory"} {
### if {![file isdirectory $e_check]} {
### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg
### }
### }
### }
### }
### char {
### #review - char vs unicode codepoint vs grapheme?
### foreach clauseval $vlist clauseval_check $vlist_check {
### set e_check [lindex $clauseval_check $clausecolumn]
### if {[tcl::string::length $e_check] != 1} {
### set e [lindex $clauseval $clausecolumn]
### set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character"
### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg
### }
### }
### }
### default {
### }
### }
###}
#new version
#list_of_clauses_raw list of (possibly)multi-value clauses for a particular argname
#common basic case: list of single item being a single value clause.
#precondition: list_of_clauses_raw has 'list protected' clauses of length 1 e.g if value is a dict {a A}
proc private::check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn default_type_expression list_of_clauses_raw list_of_clauses_check list_of_clauses_types argspecs} {
#default_type_expression is for the chosen clausecolumn
#if {$argname eq "frametype"} {
#puts "--->checking arg:$argname clausecolumn:$clausecolumn checkvalues:[lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] against default_type_expression $default_type_expression"
#puts "--->list_of_clauses_raw : $list_of_clauses_raw"
#puts "--->list_of_clauses_check: $list_of_clauses_check"
#puts "--->$argname -type: [dict get $thisarg -type]"
#}
set clause_size [llength [dict get $thisarg -type]] ;#length of full type - not just the default_type_expression for the clausecolumn
set default_type_alternatives [private::split_type_expression $default_type_expression]
#---------------------
#pre-calc prefix sets based on the default.
set alt_literals [lsearch -all -inline -index 0 $default_type_alternatives literal]
set literals [lmap v $alt_literals {lindex $v 1}]
set alt_literalprefixes [lsearch -all -inline -index 0 $default_type_alternatives literalprefix]
set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}]
#---------------------
#each type_alternative is a list of varying length depending on arguments supported by first word.
#TODO?
#single element types: int double string etc
#two element types literal literalprefix stringstartswith stringendswith
#TODO
#list for each clause (each clause is itself a list - usually length 1 but can be any length - we are dealing only with one column of the clauses)
set clause_results [lrepeat [llength $list_of_clauses_raw] [lrepeat [llength $default_type_alternatives] _]]
#e.g for list_of_clauses_raw {{a b c} {1 2 3}} when clausecolumn is 0
#-types {int|char|literal(ok) char double}
#we are checking a and 1 against the defaulttype_expression e.g int|char|literal(ok) (type_alternatives = {int char literal(ok)}
#our initial clause_results in this case is a 2x2 list {{_ _ _} {_ _ _}}
#review: for a particular clause the active type_expression might be overridden with 'any' if the column has already passed a -choices test
#
set e_vals [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_raw *]
set check_vals [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *]
set typelist_vals_raw [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_types *]
set typelist_vals [lmap v $typelist_vals_raw {string trim $v ?}]
set c_idx -1
foreach e $e_vals e_check $check_vals clause_column_type_expression $typelist_vals {
incr c_idx
set col_type_alternatives [private::split_type_expression $clause_column_type_expression]
set firstany [lsearch -exact $col_type_alternatives any]
if {$firstany > -1} {
lset clause_results $c_idx $firstany 1
continue
}
set a_idx -1
foreach typealt $col_type_alternatives {
incr a_idx
lassign $typealt type testval ;#testval will be empty for basic types, but applies to literal, literalprefix, stringstartswith etc.
switch -exact -- $type {
literal {
if {$e ne $testval} {
set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
#this clause is satisfied - no need to process it for other typealt
break
}
}
literalprefix {
#this specific literalprefix testval value not relevant - we're testing against all in the set of typealternates
set match [::tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $e]
if {$match ne "" && $match ni $literals} {
lset clause_results $c_idx $a_idx 1
#this clause is satisfied - no need to process it for other typealt
break
} else {
set msg "$argclass '$argname' for %caller% requires unambiguous literal prefix match for one of '$literalprefixes' within prefix calculation set:'[list {*}$literals {*}$literalprefixes]'. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg]
}
}
stringstartswith {
if {[string match $testval* $e]} {
lset clause_results $c_idx $a_idx 1
break
} else {
set msg "$argclass '$argname' for %caller% requires stringstartswith value '$testval'. Received: '$e'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg]
}
}
stringendswith {
if {[string match *$testval $e]} {
lset clause_results $c_idx $a_idx 1
break
} else {
set msg "$argclass '$argname' for %caller% requires stringendswith value '$testval'. Received: '$e'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg]
}
}
list {
if {![tcl::string::is list -strict $e_check]} {
set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs] msg $msg]
continue
} else {
if {[dict exists $thisarg_checks -minsize]} {
# -1 for disable is as good as zero
set minsize [dict get $thisarg_checks -minsize]
if {[llength $e_check] < $minsize} {
set msg "$argclass '$argname for %caller% requires list with -minsize $minsize. Received len:[llength $e_check]"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg]
continue
}
}
if {[dict exist $thisarg_checks -maxsize]} {
set maxsize [dict get $thisarg_checks -maxsize]
if {$maxsize ne "-1"} {
if {[llength $e_check] > $maxsize} {
set msg "$argclass '$argname for %caller% requires list with -maxsize $maxsize. Received len:[llength $e_check]"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg]
continue
}
}
}
}
lset clause_results $c_idx $a_idx 1
break
}
regex - regexp {
if {[catch {regexp -about $e_check} re_about_msg]} {
set msg "$argclass $argname for %caller% requires type regexp. $re_about_msg. Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
#optional -mincap and -maxcap specify number of allowed subexpressions(capture groups) present in regex
set num_caps [lindex $re_about_msg 0]
set mincap 0 ;#default
set maxcap -1 ;#default -1 for unlimited
if {[dict exists $thisarg_checks -mincap]} {
set mincap [dict get $thisarg_checks -mincap]
}
if {[dict exists $thisarg_checks -maxcap]} {
set maxcap [dict get $thisarg_checks -maxcap]
}
if {$maxcap == -1 && $mincap == 0} {
#no cap limits - just accept the regex as valid
lset clause_results $c_idx $a_idx 1
break
} else {
#we have at least one cap limit - we need to count the number of subexpressions in the regex and check it against the limits
if {$maxcap == -1} {
#unlimited maxcap - just check mincap
if {$num_caps < $mincap} {
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
} else {
if {$num_caps < $mincap} {
set msg "$argclass $argname for %caller% requires type regexp with at least $mincap capture groups. Received regex has only $num_caps capture groups. Regex: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} elseif {$num_caps > $maxcap} {
set msg "$argclass $argname for %caller% requires type regexp with no more than $maxcap capture groups. Received regex has $num_caps capture groups. Regex: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
} ;#every leaf of this nested if should have an lset clause_results with 1 for pass or errorcode/msg for fail
}
}
indexexpression {
#tcl 9.1+? tip 615 'string is index'
if {$e_check eq "" || [catch {lindex {} $e_check}]} {
set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
indexset {
if {![punk::lib::is_indexset $e_check]} {
set msg "$argclass $argname for %caller% requires type indexset. A comma-delimited set of indexes or index-ranges separated by '..' Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
packageversion {
if {[catch {::package vsatisfies $e_check $e_check}]} {
set msg "$argclass $argname for %caller% requires type packageversion. A package version number as understood by 'package vsatifies'. Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
packagerequirement {
set parts [split $e_check -]
if {[llength $parts] > 2} {
set msg "$argclass $argname for %caller% requires type packagerequirement. (form min min- or min-max) Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
set vchecklist [list]
if {[llength $parts] == 1} {
lappend vchecklist [lindex $parts 0]
} else {
lassign $parts vmin vmax
if {$vmax eq ""} {
#empty vmax allowed - ignore
lappend vchecklist $vmin
} else {
lappend vchecklist $vmin $vmax
}
}
#we have either just the min, or min and max
set v_ok 1 ;#default assumption
foreach vcheck $vchecklist {
if {[catch {::package vsatisfies $vcheck $vcheck}]} {
set msg "$argclass $argname for %caller% requires type packagerequirement. (from min min- or min-max) . Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
set v_ok 0
break ;#inner loop
}
}
if {$v_ok} {
lset clause_results $c_idx $a_idx 1
break
}
}
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?
#review - order of -regexprepass and -regexprefail in original rawargs significant?
#for now -regexprepass always takes precedence
#REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults?
set regexprepass [tcl::dict::get $thisarg -regexprepass]
set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9
if {$regexprepass ne ""} {
if {[regexp [lindex $regexprepass $clausecolumn] $e]} {
lset clause_results $c_idx $a_idx 1
break
}
}
if {$regexprefail ne ""} {
#puts "----> checking $e vs regex $regexprefail"
if {[regexp $regexprefail $e]} {
if {[tcl::dict::exists $thisarg -regexprefailmsg]} {
#review - %caller% ??
set msg [tcl::dict::get $thisarg -regexprefailmsg]
} else {
set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'"
}
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs] msg $msg]
#review - tests?
continue
}
}
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 $clauses_dict not $clauses_dict_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
if {![punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
}
globstring {
if {![regexp {[*?\[\]]} $e]} {
set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
}
}
if {[tcl::dict::size $thisarg_checks]} {
if {[dict exists $thisarg_checks -minsize]} {
set minsize [dict get $thisarg_checks -minsize]
# -1 for disable is as good as zero
if {[tcl::string::length $e_check] < $minsize} {
set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
}
if {[dict exists $thisarg_checks -maxsize]} {
set maxsize [dict get $thisarg_checks -maxsize]
if {$maxsize ne "-1"} {
if {[tcl::string::length $e_check] > $maxsize} {
set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
}
}
}
lset clause_results $c_idx $a_idx 1
break
}
number {
#review - consider effects of Nan and Inf
#NaN can be considered as 'technically' a number (or at least a special numeric value)
if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} {
set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
if {[tcl::dict::exists $thisarg -typeranges]} {
set ranges [tcl::dict::get $thisarg -typeranges]
set range [lindex $ranges $clausecolumn]
lassign {} low high ;#set both empty
lassign $range low high
if {"$low$high" ne ""} {
if {[::tcl::mathfunc::isnan $e]} {
set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
if {$low eq ""} {
if {$e_check > $high} {
set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
} elseif {$high eq ""} {
if {$e_check < $low} {
set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
} else {
if {$e_check < $low || $e_check > $high} {
set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
}
}
}
lset clause_results $c_idx $a_idx 1
break
}
int {
#elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive
if {![tcl::string::is integer -strict $e_check]} {
set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
if {[tcl::dict::exists $thisarg -typeranges]} {
set ranges [tcl::dict::get $thisarg -typeranges]
set range [lindex $ranges $clausecolumn]
lassign $range low high
if {"$low$high" ne ""} {
if {$low eq ""} {
#lowside unspecified - check only high
if {$e_check > $high} {
set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
} elseif {$high eq ""} {
#highside unspecified - check only low
if {$e_check < $low} {
set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
} else {
#high and low specified
if {$e_check < $low || $e_check > $high} {
set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
}
}
}
lset clause_results $c_idx $a_idx 1
break
}
double {
if {![tcl::string::is double -strict $e_check]} {
set msg "$argclass $argname for %caller% requires type double. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
if {[tcl::dict::exists $thisarg_checks -typeranges]} {
set ranges [dict get $thisarg_checks -typeranges]
set range [lindex $ranges $clausecolumn]
#todo - small-value double comparisons with error-margin? review
lassign $range low high
if {"$low$high" ne ""} {
if {$low eq ""} {
#lowside unspecified - check only high
if {$e_check > $high} {
set msg "$argclass $argname for %caller% must be double less than or equal to $high. Received: '$e'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
} elseif {$high eq ""} {
#highside unspecified - check only low
if {$e_check < $low} {
set msg "$argclass $argname for %caller% must be double greater than or equal to $low. Received: '$e'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
} elseif {$e_check < $low || $e_check > $high} {
set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
}
}
lset clause_results $c_idx $a_idx 1
break
}
bool {
if {![tcl::string::is boolean -strict $e_check]} {
set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'"
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
dict {
#to maintain support for tcl 8.6 - can't directly use 'string is dict'
if {![punk::args::lib::string_is_dict $e_check]} {
set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
#if {[llength $e_check] %2 != 0} {
#}
if {[tcl::dict::size $thisarg_checks]} {
if {[dict exists $thisarg_checks -minsize]} {
set minsizes [dict get $thisarg_checks -minsize]
set minsize [lindex $minsizes $clausecolumn]
# -1 for disable is as good as zero
if {[tcl::dict::size $e_check] < $minsize} {
set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]"
lset clause_results $c_idx $a_idx [list err [list sizeviolation $type minsize $minsize] msg $msg]
continue
}
}
if {[dict exists $thisarg_checks -maxsize]} {
set maxsize [lindex $maxsizes $clausecolumn]
if {$maxsize ne "-1"} {
if {[tcl::dict::size $e_check] > $maxsize} {
set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]"
lset clause_results $c_idx $a_idx [list err [list sizeviolation $type maxsize $maxsize] msg $msg]
continue
}
}
}
}
lset clause_results $c_idx $a_idx 1
}
alnum -
alpha -
ascii -
control -
digit -
graph -
lower -
print -
punct -
space -
upper -
wordchar -
xdigit {
#todo - combined types xdigit && lower ?? set-theoretic types? how?
if {![tcl::string::is $type -strict $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
path -
file -
directory {
#see comments in existingpath/existingfile/existingdirectory case about the challenges of validating filesystem paths in a general way that works across platforms and use cases.
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a path, file or directory"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
lset clause_results $c_idx $a_idx 1
}
existingpath -
existingfile -
existingdirectory {
#do we need types for relative vs absolute paths? readable writable executable owned?
#on windows limit to certain file extensions?
#fileutil::magic::filetype?
#Perhaps these are steps too far for a general validation framework.
#consider - callback validation functions instead?
#ideally we want to define callback validation functions that can work not just on a single argument at a time.
#e.g for testing that 2 file arguments do or don't refer to the same file or are in same directory or same filesystem etc.
#we have to support file and directory names on all platforms - and even characters illegal on a filesystem/platform may need to be passed.
#For example a file/folder may be created with an illegal name on a platform (or mounted on it) and be mapped to another string on the filesystem
#- yet it may remain accessible to commands such as file stat etc via the string with 'illegal' characters as well as its underlying stored (mapped) name.
#NUL is almost universally problematic - so we will reject.
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
# -------------------------------------------------------
#review - what do we want to happen with links?
#on unix TCL's file readlink should reliably give us a path to determine the type pointed to.
#on windows we can do so if the link happens to be a junction.
#however on windows we can also have symbolic links which are not junctions and which may point to files or directories
#- but unfortunately tcl's file readlink doesn't seem to be able to read them at all - raises an error.
#(the error seems to be different for a file vs a directory target - but this seems an unreliable mechanism to determine the type of the target)
#At the moment TCL's 'file isfile' and 'file isdirectory' both seem to do the right things for links
#despite the above - treating them as the type of their target
# review whether this is reliable in all cases on windows.
# -------------------------------------------------------
#windows shortcuts (.lnk files) can point to a file or directory - but we can quite reasonably treat them only as files,
#as users *probably* won't have the expectation that a shortcut which points to a directory should be treated as a directory.
switch -exact -- $type {
existingpath {
if {![file exists $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing path"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
}
existingfile {
if {![file isfile $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
}
existingdirectory {
if {![file isdirectory $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
}
}
lset clause_results $c_idx $a_idx 1
}
existingportablefile -
existingportabledirectory -
portablefile -
portabledirectory {
#review - many absolute paths are not strictly portable when considered as a whole e.g /usr/local/bin c:/test
#- but the idea was more about the directory and file name components being portable excluding the first component.
#this concept may need work as it's unintuitive what it means to be a portable file/directory vs not.
#what about windows specific paths such as //?/ //./ or UNC paths?
if {[tcl::string::length $e_check]==0 || [string first \0 $e_check] >= 0 || [punk::winpath::illegalname_test $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a portable file or directory (must pass punk::winpath::illegalname_test)"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
if {$type eq "existingportablefile"} {
if {![file exists $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
} elseif {$type eq "existingportabledirectory"} {
if {![file isdirectory $e_check]} {
set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
}
lset clause_results $c_idx $a_idx 1
}
char {
#review - char vs unicode codepoint vs grapheme?
if {[tcl::string::length $e_check] != 1} {
set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character"
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
tk_screen_units {
switch -exact -- [string index $e_check end] {
c - i - m - p {
set numpart [string range $e_check 0 end-1]
if {![tcl::string::is double $numpart]} {
set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels."
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
}
default {
if {![tcl::string::is double $e_check]} {
set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels."
lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg]
continue
}
}
}
lset clause_results $c_idx $a_idx 1
break
}
default {
#default pass for unrecognised types - review.
lset clause_results $c_idx $a_idx 1
break
}
}
}
}
foreach clauseresult $clause_results {
if {[lsearch $clauseresult 1] == -1} {
#no pass for this clause - fetch first? error and raise
#todo - return error containing clause_indices so we can report more than one failing element at once?
foreach e $clauseresult {
switch -exact -- [lindex $e 0] {
errorcode {
#errorcode <list> msg <string
set errorcode [lindex $e 1]
set msg [lindex $e 3]
return -options [list -code error -errorcode $errorcode] $msg
}
err {
set errorcode [list PUNKARGS VALIDATION [lindex $e 1] -badarg $argname -badval $e_check -argspecs $argspecs]
set msg [lindex $e 3]
return -options [list -code error -errorcode $errorcode] $msg
}
}
}
}
}
return
}
##interim version
##list_of_clauses_raw list of (possibly)multi-value clauses for a particular argname
##common basic case: list of single item being a single value clause.
##precondition: list_of_clauses_raw has 'list protected' clauses of length 1 e.g if value is a dict {a A}
#proc _check_clausecolumn2 {argname argclass thisarg thisarg_checks clausecolumn type_expression list_of_clauses_raw list_of_clauses_check argspecs} {
# if {$argname eq "frametype"} {
# puts "--->checking arg:$argname clausecolumn:$clausecolumn checkvalues:[lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] against type_expression $type_expression"
# puts "--->list_of_clauses_raw : $list_of_clauses_raw"
# puts "--->list_of_clauses_check: $list_of_clauses_check"
# puts "--->$argname -type: [dict get $thisarg -type]"
# }
# set clause_size [llength [dict get $thisarg -type]] ;#length of full type - not just passed type_expression
# #set vlist [list]
# set clauses_dict [dict create] ;#key is ordinal position, remove entries as they are satsified
# set cidx -1
# foreach cv $list_of_clauses_raw {
# incr cidx
# #REVIEW
# #if {$clause_size ==1} {
# # lappend vlist [list $cidx [list $cv]]
# #} else {
# #lappend vlist [list $cidx $cv] ;#store the index so we can reduce vlist as we go
# dict set clauses_dict $cidx $cv
# #}
# }
# #set vlist_check [list]
# set clauses_dict_check [dict create]
# set cidx -1
# foreach cv $list_of_clauses_check {
# incr cidx
# #if {$clause_size == 1} {
# # lappend vlist_check [list $cidx [list $cv]]
# #} else {
# #lappend vlist_check [list $cidx $cv]
# dict set clauses_dict_check $cidx $cv
# #}
# }
# set type_alternatives [private::split_type_expression $type_expression]
# #each type_alternative is a list of varying length depending on arguments supported by first word.
# #TODO?
# #single element types: int double string etc
# #two element types literal literalprefix stringstartswith stringendswith
# #TODO
# #list for each clause (each clause is itself a list - usually length 1 but can be any length - we are dealing only with one column of the clauses)
# set clause_results [lrepeat [llength $list_of_clauses_raw] [lrepeat [llength $type_alternatives] _]]
# #e.g for list_of_clauses_raw {{a b c} {1 2 3}} when clausecolumn is 0
# #-types {int|char|literal(ok) char double}
# #we are checking a and 1 against the type_expression int|char|literal(ok) (type_alternatives = {int char literal(ok)}
# #our initial clause_results in this case is a 2x2 list {{_ _ _} {_ _ _}}
# #
# set a_idx -1
# foreach typealt $type_alternatives {
# incr a_idx
# set type [lindex $typealt 0]
# #e.g int
# #e.g {literal blah}
# #e.g {literalprefix abc}
# #switch on first word of each typealt
# #
# #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ?
# switch -- $type {
# any {}
# literal {
# dict for {c_idx clauseval} $clauses_dict {
# set e [lindex $clauseval $clausecolumn]
# set testval [lindex $typealt 1]
# if {$e ne $testval} {
# set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg]
# } else {
# lset clause_results $c_idx $a_idx 1
# #this clause is satisfied - no need to process it for other typealt
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# literalprefix {
# set alt_literals [lsearch -all -inline -index 0 $type_alternatives literal]
# set literals [lmap v $alt_literals {lindex $v 1}]
# set alt_literalprefixes [lsearch -all -inline -index 0 $type_alternatives literalprefix]
# set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}]
# dict for {c_idx clauseval} $clauses_dict {
# set e [lindex $clauseval $clausecolumn]
# #this specific literalprefix value not relevant - we're testing against all in the set of typealternates
# #set testval [lindex $typealt 1]
# set match [::tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $e]
# if {$match ne "" && $match ni $literals} {
# lset clause_results $c_idx $a_idx 1
# #this clause is satisfied - no need to process it for other typealt
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# } else {
# set msg "$argclass '$argname' for %caller% requires unambiguous literal prefix match for one of '$literalprefixes' within prefix calculation set:'[list {*}$literals {*}$literalprefixes]'. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg]
# }
# }
# }
# stringstartswith {
# dict for {c_idx clauseval} $clauses_dict {
# set e [lindex $clauseval $clausecolumn]
# set testval [lindex $typealt 1]
# if {[string match $testval* $e]} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# } else {
# set msg "$argclass '$argname' for %caller% requires stringstartswith value '$testval'. Received: '$e'"
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg]
# }
# }
# }
# stringendswith {
# dict for {c_idx clauseval} $clauses_dict {
# set e [lindex $clauseval $clausecolumn]
# set testval [lindex $typealt 1]
# if {[string match *$testval $e]} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# } else {
# set msg "$argclass '$argname' for %caller% requires stringendswith value '$testval'. Received: '$e'"
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg]
# }
# }
# }
# list {
# dict for {c_idx clauseval_check} $clauses_dict_check {
# set e_check [lindex $clauseval_check $clausecolumn]
# set passed_checks 1
# if {![tcl::string::is list -strict $e_check]} {
# set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'"
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs] msg $msg]
# set passed_checks 0
# } else {
# if {[dict exists $thisarg_checks -minsize]} {
# # -1 for disable is as good as zero
# set minsize [dict get $thisarg_checks -minsize]
# if {[llength $e_check] < $minsize} {
# set msg "$argclass '$argname for %caller% requires list with -minsize $minsize. Received len:[llength $e_check]"
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# if {$passed_checks && [dict exist $thisarg_checks -maxsize]} {
# set maxsize [dict get $thisarg_checks -maxsize]
# if {$maxsize ne "-1"} {
# if {[llength $e_check] > $maxsize} {
# set msg "$argclass '$argname for %caller% requires list with -maxsize $maxsize. Received len:[llength $e_check]"
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# }
# }
# if {$passed_checks} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# indexexpression {
# dict for {c_idx clauseval_check} $clauses_dict_check {
# set e_check [lindex $clauseval_check $clausecolumn]
# if {[catch {lindex {} $e_check}]} {
# set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# } else {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# 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?
# #review - order of -regexprepass and -regexprefail in original rawargs significant?
# #for now -regexprepass always takes precedence
# #REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults?
# set regexprepass [tcl::dict::get $thisarg -regexprepass]
# set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9
# if {$regexprepass ne ""} {
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# set e [lindex $clauseval $clausecolumn]
# set e_check [lindex $clauseval_check $clausecolumn]
# if {[regexp [lindex $regexprepass $clausecolumn] $e]} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# if {$regexprefail ne ""} {
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# set e [lindex $clauseval $clausecolumn]
# set e_check [lindex $clauseval_check $clausecolumn]
# #puts "----> checking $e vs regex $regexprefail"
# if {[regexp $regexprefail $e]} {
# if {[tcl::dict::exists $thisarg -regexprefailmsg]} {
# #review - %caller% ??
# set msg [tcl::dict::get $thisarg -regexprefailmsg]
# } else {
# set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'"
# }
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs] msg $msg]
# #review - tests?
# }
# }
# }
# 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 $clauses_dict not $clauses_dict_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
# dict for {c_idx clauseval} $clauses_dict {
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# set e [lindex $clauseval $clausecolumn]
# if {![punk::ansi::ta::detect $e]} {
# set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# }
# }
# }
# globstring {
# dict for {c_idx clauseval} $clauses_dict {
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# set e [lindex $clauseval $clausecolumn]
# if {![regexp {[*?\[\]]} $e]} {
# set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# }
# }
# }
# }
# dict for {c_idx clauseval_check} $clauses_dict_check {
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# if {[tcl::dict::size $thisarg_checks]} {
# set passed_checks 1
# set e_check [lindex $clauseval_check $clausecolumn]
# if {[dict exists $thisarg_checks -minsize]} {
# set minsize [dict get $thisarg_checks -minsize]
# # -1 for disable is as good as zero
# if {[tcl::string::length $e_check] < $minsize} {
# set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# if {$passed_checks && [dict exists $thisarg_checks -maxsize]} {
# set maxsize [dict get $thisarg_checks -maxsize]
# if {$checkval ne "-1"} {
# if {[tcl::string::length $e_check] > $maxsize} {
# set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# }
# if {$passed_checks} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# } else {
# if {[lindex $clause_results $c_idx $a_idx] eq "_"} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# }
# number {
# #review - consider effects of Nan and Inf
# #NaN can be considered as 'technically' a number (or at least a special numeric value)
# dict for {c_idx clauseval_check} $clauses_dict_check {
# set e_check [lindex $clauseval_check $clausecolumn]
# if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} {
# set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# }
# }
# if {[tcl::dict::exists $thisarg -typeranges]} {
# set ranges [tcl::dict::get $thisarg -typeranges]
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# set e [lindex $clauseval $clausecolumn]
# set e_check [lindex $clauseval_check $clausecolumn]
# set range [lindex $ranges $clausecolumn]
# lassign {} low high ;#set both empty
# lassign $range low high
# set passed_checks 1
# if {"$low$high" ne ""} {
# if {[::tcl::mathfunc::isnan $e]} {
# set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# if {$passed_checks} {
# if {$low eq ""} {
# if {$e_check > $high} {
# set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# } elseif {$high eq ""} {
# if {$e_check < $low} {
# set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# } else {
# if {$e_check < $low || $e_check > $high} {
# set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# }
# }
# if {$passed_checks} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict usnet clauses_dict_check $c_idx
# }
# }
# } else {
# dict for {c_idx clauseval} $clauses_dict {
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict usnet clauses_dict_check $c_idx
# }
# }
# }
# int {
# #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive
# dict for {c_idx clauseval_check} $clauses_dict_check {
# set e_check [lindex $clauseval_check $clausecolumn]
# if {![tcl::string::is integer -strict $e_check]} {
# set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# }
# }
# if {[tcl::dict::exists $thisarg -typeranges]} {
# set ranges [tcl::dict::get $thisarg -typeranges]
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# set e [lindex $clauseval $clausecolumn]
# set e_check [lindex $clauseval_check $clausecolumn]
# set range [lindex $ranges $clausecolumn]
# lassign $range low high
# set passed_checks 1
# if {"$low$high" ne ""} {
# if {$low eq ""} {
# #lowside unspecified - check only high
# if {$e_check > $high} {
# set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# } elseif {$high eq ""} {
# #highside unspecified - check only low
# if {$e_check < $low} {
# set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# } else {
# #high and low specified
# if {$e_check < $low || $e_check > $high} {
# set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'"
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# }
# if {$passed_checks} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# } else {
# dict for {c_idx clauseval} $clauses_dict {
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# double {
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# set e_check [lindex $clauseval_check $clausecolumn]
# if {![tcl::string::is double -strict $e_check]} {
# set e [lindex $clauseval $clausecolumn]
# set msg "$argclass $argname for %caller% requires type double. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# }
# }
# if {[tcl::dict::exists $thisarg_checks -typeranges]} {
# set ranges [dict get $thisarg_checks -typeranges]
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# set e_check [lindex $clauseval_check $clausecolumn]
# set range [lindex $ranges $clausecolumn]
# #todo - small-value double comparisons with error-margin? review
# #todo - empty string for low or high
# set passed_checks 1
# lassign $range low high
# if {$low$high ne ""} {
# if {$e_check < $low || $e_check > $high} {
# set e [lindex $clauseval $clausecolumn]
# set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# if {$passed_checks} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# } else {
# dict for {c_idx clauseval} $clauses_dict {
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# bool {
# dict for {c_idx clauseval_check} $clauses_dict_check {
# set e_check [lindex $clauseval_check $clausecolumn]
# if {![tcl::string::is boolean -strict $e_check]} {
# set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# } else {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# dict {
# dict for {c_idx clauseval_check} $clauses_dict_check {
# puts "check_clausecolumn2 dict handler: c_idx:$c_idx clausecolumn:$clausecolumn clauseval_check:$clauseval_check"
# set e_check [lindex $clauseval_check $clausecolumn]
# if {[llength $e_check] %2 != 0} {
# set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg]
# }
# }
# dict for {c_idx clauseval_check} $clauses_dict_check {
# if {[lindex $clause_results $c_idx $a_idx] ne "_"} {
# continue
# }
# set passed_checks 1
# if {[tcl::dict::size $thisarg_checks]} {
# if {[dict exists $thisarg_checks -minsize]} {
# set minsizes [dict get $thisarg_checks -minsize]
# set e_check [lindex $clauseval_check $clausecolumn]
# set minsize [lindex $minsizes $clausecolumn]
# # -1 for disable is as good as zero
# if {[tcl::dict::size $e_check] < $minsize} {
# set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# if {$passed_checks && [dict exists $thisarg_checks -maxsize]} {
# set e_check [lindex $clauseval_check $clausecolumn]
# set maxsize [lindex $maxsizes $clausecolumn]
# if {$maxsize ne "-1"} {
# if {[tcl::dict::size $e_check] > $maxsize} {
# set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# }
# }
# if {$passed_checks} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# alnum -
# alpha -
# ascii -
# control -
# digit -
# graph -
# lower -
# print -
# punct -
# space -
# upper -
# wordchar -
# xdigit {
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# set e_check [lindex $clauseval_check $clausecolumn]
# if {![tcl::string::is $type -strict $e_check]} {
# set e [lindex $clauseval $t]
# set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# } else {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# file -
# directory -
# existingfile -
# existingdirectory {
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# set e [lindex $clauseval $clausecolumn]
# set e_check [lindex $clauseval_check $clausecolumn]
# #//review - we may need '?' char on windows
# set passed_checks 1
# if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} {
# #what about special file names e.g on windows NUL ?
# set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# if {$passed_checks} {
# if {$type eq "existingfile"} {
# if {![file exists $e_check]} {
# set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# } elseif {$type eq "existingdirectory"} {
# if {![file isdirectory $e_check]} {
# set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# }
# if {$passed_checks} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# char {
# #review - char vs unicode codepoint vs grapheme?
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# set e_check [lindex $clauseval_check $clausecolumn]
# if {[tcl::string::length $e_check] != 1} {
# set e [lindex $clauseval $clausecolumn]
# set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character"
# #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg]
# } else {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# tk_screen_units {
# dict for {c_idx clauseval} $clauses_dict {
# set clauseval_check [dict get $clauses_dict_check $c_idx]
# set e_check [lindex $clauseval_check $clausecolumn]
# set passed_checks 1
# switch -exact -- [string index $e_check end] {
# c - i - m - p {
# set numpart [string range $e_check 0 end-1]
# if {![tcl::string::is double $numpart]} {
# set e [lindex $clauseval $clausecolumn]
# set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels."
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# default {
# if {![tcl::string::is double $e_check]} {
# set e [lindex $clauseval $clausecolumn]
# set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels."
# lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg]
# set passed_checks 0
# }
# }
# }
# if {$passed_checks} {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# default {
# #default pass for unrecognised types - review.
# dict for {c_idx clauseval} $clauses_dict {
# lset clause_results $c_idx $a_idx 1
# dict unset clauses_dict $c_idx
# dict unset clauses_dict_check $c_idx
# }
# }
# }
# }
# foreach clauseresult $clause_results {
# if {[lsearch $clauseresult 1] == -1} {
# #no pass for this clause - fetch first? error and raise
# #todo - return error containing clause_indices so we can report more than one failing element at once?
# foreach e $clauseresult {
# if {[lindex $e 0] eq "errorcode"} {
# #errorcode <list> msg <string
# set err [lindex $e 1]
# set msg [lindex $e 3]
# return -options [list -code error -errorcode $err] $msg
# }
# }
# }
# }
#}
#todo? - a version of get_dict that directly supports punk::lib::tstr templating
#rename get_dict
#
#G-040: the single implementation of choice-word matching - shared by argument parsing
#(get_dict) and the punk::ns doc-lookup walk (cmd_traverse), so 'i <cmd> <word>'
#resolution can never diverge from what parsing accepts.
lappend PUNKARGS [list {
@id -id ::punk::args::choiceword_match
@cmd -name punk::args::choiceword_match\
-summary\
"Match a supplied word against an argument's choices (the shared choice-matching implementation)."\
-help\
"The single implementation of choice-word matching - shared by argument
parsing (get_dict) and the punk::ns doc-lookup walk (cmd_traverse), so
'i <cmd> <word>' resolution can never diverge from what parsing accepts.
(G-040)
Returns a dict with keys:
matched - boolean: word identifies a choice (directly, by unique
prefix, or via an alias)
exact - boolean: the raw stored word already equals the resulting
choice (no rewrite needed)
canonical - the resulting choice value (empty when not matched)"
@values -min 7 -max 7
word -type string -help\
"The supplied word.
Callers pass the check-form, e.g ansistripped when applicable"
nocase -type boolean -help\
"value of -nocase for the argument"
allchoices -type list -help\
"flat list of -choices plus all -choicegroups members (dups allowed)"
choicealiases -type dict -help\
"-choicealiases dict (alias -> canonical choice)"
choiceprefix -type boolean -help\
"value of -choiceprefix"
denylist -type list -help\
"-choiceprefixdenylist (full word required for these names)"
reservelist -type list -help\
"-choiceprefixreservelist (phantom prefix-calculation members)"
}]
proc choiceword_match {word nocase allchoices choicealiases choiceprefix denylist reservelist} {
set aliasnames [tcl::dict::keys $choicealiases]
set has_choicealiases [expr {[llength $aliasnames] > 0}]
set choicealiases_nocase [tcl::dict::create]
if {$has_choicealiases} {
tcl::dict::for {ca_al ca_cn} $choicealiases {
tcl::dict::set choicealiases_nocase [tcl::string::tolower $ca_al] $ca_cn
}
}
if {$nocase} {
set choices_test [tcl::string::tolower $allchoices]
set v_test [tcl::string::tolower $word]
} else {
set choices_test $allchoices
set v_test $word
}
set chosen ""
set choice_in_list 0
set choice_exact_match 0
if {$choiceprefix} {
#can we handle empty string as a choice? It should just work - REVIEW/test
if {$word in $allchoices} {
#for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
#(deliberately not 'exact' - the stored raw value must be overwritten with the canonical)
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$nocase && $v_test in $choices_test} {
#full-length match except for case
#select the case from the choice list - not the supplied value
foreach avail [lsort -unique $allchoices] {
if {[tcl::string::match -nocase $word $avail]} {
set chosen $avail
}
}
#assert chosen will always get set
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
} else {
#PREFIX check required - any match here is not an exact match or it would have matched above.
#in this block we can treat empty result from prefix match as a non-match
set prefix_via_alias 0 ;#set when the prefix match landed on an alias name (deny already applied to the alias)
if {$nocase} {
#nocase prefixing with case-dups: see the -choiceprefixdenylist nocase notes at the original
#get_dict site - counterintuitive DEL/delete/Delete edge cases are documented feature-not-bug
set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$bestmatch eq "" || $bestmatch in $reservelist} {
set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}[tcl::dict::keys $choicealiases_nocase] {*}$reservelist] $v_test]
if {$chosen ne "" && [tcl::dict::exists $choicealiases_nocase $chosen]} {
#matched an alias (lowercased) - deny applies to the alias name, then normalize
if {[lsearch -nocase $denylist $chosen] >= 0} {
set chosen ""
} else {
set chosen [tcl::dict::get $choicealiases_nocase $chosen]
set prefix_via_alias 1
}
set choice_in_list [expr {$chosen ne ""}]
} else {
#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 {
if {$bestmatch in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$bestmatch in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $bestmatch]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $bestmatch
set choice_in_list 1
}
}
} else {
set matchedname [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$aliasnames {*}$reservelist] $word]
if {$matchedname eq "" || $matchedname in $reservelist} {
set chosen ""
set choice_in_list 0
} elseif {$matchedname in $aliasnames} {
#prefix landed on an alias - deny applies to the alias name, then normalize
if {$matchedname in $denylist} {
set chosen ""
set choice_in_list 0
} else {
set chosen [tcl::dict::get $choicealiases $matchedname]
set choice_in_list 1
set prefix_via_alias 1
}
} else {
set chosen $matchedname
set choice_in_list 1
}
}
#don't allow prefixing for elements from -choiceprefixdenylist
#we still use all elements to calculate the prefixes though
#(a canonical reached via an alias is exempt - deny was already applied to the alias name)
#review - case difference edge cases in choiceprefixdenylist !todo
if {!$prefix_via_alias && $chosen in $denylist} {
set choice_in_list 0
set chosen ""
}
}
} else {
#-choiceprefix false - exact matching only
if {$v_test in $choices_test} {
#value as stored is ok (raw word kept - historical behaviour, including nocase raw retention)
set chosen $word
set choice_in_list 1
set choice_exact_match 1
} elseif {$has_choicealiases && [tcl::dict::exists $choicealiases $word]} {
#exact alias match - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases $word]
set choice_in_list 1
} elseif {$has_choicealiases && $nocase && [tcl::dict::exists $choicealiases_nocase $v_test]} {
#exact alias match differing only by case - normalize to the canonical choice
set chosen [tcl::dict::get $choicealiases_nocase $v_test]
set choice_in_list 1
}
}
return [tcl::dict::create matched $choice_in_list exact $choice_exact_match canonical $chosen]
}
#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.
lappend PUNKARGS [list {
@id -id ::punk::args::get_dict
@cmd -name punk::args::get_dict\
-summary\
"Parse an argument list against a raw definition - the core parsing engine."\
-help\
"The core argument parsing/validation engine underlying
punk::args::parse (which is the preferred API for procs).
Parses rawargs against the supplied raw definition list and returns
a dict with keys: leaders, opts, values (argument name/value dicts)
and received (names of arguments actually supplied, with ordinal
clause info where applicable), plus solos.
Raises an error (rendering a usage table according to the errorstyle
in effect) if the arguments don't conform to the definition."
@leaders -min 2 -max 2
deflist -type list -help\
"Raw definition list (list of definition blocks)"
rawargs -type list -help\
"list of arguments to parse against the definition"
@opts
-form -default * -help\
"Restrict parsing to the listed forms - a list whose elements are
each an ordinal index or name of a command form.
The default * attempts every form: an argument list cleanly
matching exactly one form is parsed against it (auto-selection),
matching none raises an error naming each candidate form's
failure, and matching several raises an error naming the
matching forms (pass a single form to disambiguate)."
}]
proc get_dict {deflist rawargs args} {
#see arg_error regarding considerations around unhappy-path performance
set defaults [dict create {*}{
-form *
}]
#if {![punk::args::lib::string_is_dict $args]} {
# error "punk::args::get_dict args must be a dict of option value pairs"
#}
set proc_opts [dict merge $defaults $args]
dict for {k v} $proc_opts {
switch -- $k {
-form {}
default {
error "punk::args::get_dict Unexpected option '$k' Known options -form"
}
}
}
#*** !doctools
#[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]]
#[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values
#[para]Returns a dict of the form: opts <options_dict> values <values_dict>
#[para]ARGUMENTS:
#[list_begin arguments]
#[arg_def list-of-multiline-string deflist]
#[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced
#[para]'info complete' is used to determine if a record spans multiple lines due to multiline values
#[para]Each optionspec line defining a flag must be of the form:
#[para]-optionname -key val -key2 val2...
#[para]where the valid keys for each option specification are: -default -type -range -choices -optional etc
#[para]Each optionspec line defining a positional argument is of the form:
#[para]argumentname -key val -ky2 val2...
#[para]where the valid keys for each option specification are: -default -type -range -choices
#[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value
#[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings.
#[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow.
#[arg_def list rawargs]
#[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc,
#but it could be a manually constructed list of values made for example from positional args defined in the proc.
#[list_end]
#[para]
#consider line-processing example below for which we need info complete to determine record boundaries
#punk::args::get_dict [list {
# @opts
# -opt1 -default {}
# -opt2 -default {
# etc
# }
# @values -multiple 1
#}] $args
#rawargs: args values to be parsed
#we take a definition list rather than resolved argspecs - because the definition could be dynamic
#if definition has been seen before,
#define will either return a permanently cached argspecs (-dynamic 0) - or
# use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs.
set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
#argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info
# -----------------------------------------------
# Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc)
#tcl::dict::with argspecs {} ;#turn keys into vars
#e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names
# -----------------------------------------------
#we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with
set form_names [dict get $argspecs form_names]
#G-041: -form accepts a list of form names/indices (default * = all forms)
set selected_forms [private::form_selection $form_names [dict get $proc_opts -form] "punk::args::get_dict"]
if {[llength $selected_forms] == 1} {
return [private::get_dict_form $argspecs [lindex $selected_forms 0] $rawargs]
}
#G-041 multi-form candidacy: attempt each selected form independently.
#Exactly one clean parse -> auto-selected. None -> a noformmatch error naming each
#candidate form's failure (ranked best-candidate first - see rank_form_failures).
#Several -> a multipleformmatches error: no silent preference between matching
#forms - callers with an intended form pass -form (decision recorded in G-041).
set matched [list]
set matchresult ""
set formfailures [dict create]
foreach fid $selected_forms {
if {[catch {private::get_dict_form $argspecs $fid $rawargs} fresult ropts]} {
set ecode [Dict_getdef $ropts -errorcode ""]
if {[lrange $ecode 0 1] ne [list PUNKARGS VALIDATION]} {
#not a per-form validation outcome (e.g definition error) - propagate
return -options $ropts $fresult
}
set classinfo [lindex $ecode 2]
set failureclass [lindex $classinfo 0]
dict set formfailures $fid [dict create\
status [private::parse_status_classify $failureclass [lrange $classinfo 1 end]]\
failureclass $failureclass\
badarg [Dict_getdef [lrange $ecode 3 end] -badarg ""]\
message [lindex [split $fresult \n] 0]\
]
} else {
lappend matched $fid
if {[llength $matched] == 1} {
set matchresult $fresult
}
}
}
switch -- [llength $matched] {
1 {
#auto-selected - report every candidate's status alongside the result
#(partial-arglist consumers e.g command completion want per-form
#compatibility, not only the winner - see G-044)
set formstatus [dict create]
foreach fid $selected_forms {
if {$fid eq [lindex $matched 0]} {
dict set formstatus $fid [dict create status valid]
} else {
dict set formstatus $fid [dict get $formfailures $fid]
}
}
dict set matchresult formstatus $formstatus
return $matchresult
}
0 {
set formfailures [private::rank_form_failures $argspecs $rawargs $formfailures]
set candidate_fids [dict keys $formfailures]
set classes [lmap finfo [dict values $formfailures] {dict get $finfo status}]
set msg "Bad arguments for %caller%. No form of the command matches the supplied arguments. Candidate forms: $candidate_fids"
dict for {fid finfo} $formfailures {
append msg \n " form '$fid': [dict get $finfo message]"
}
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list noformmatch forms $candidate_fids classes $classes] -argspecs $argspecs -formerrors $formfailures]] $msg
}
default {
set msg "Ambiguous arguments for %caller%. The supplied arguments match more than one form: [join $matched {, }]. Use -form to select the intended form."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list multipleformmatches forms $matched] -argspecs $argspecs]] $msg
}
}
}
#parse rawargs against a single form of a resolved definition - the raising engine
#body, extracted verbatim from get_dict when multi-form candidacy landed (G-041).
#argspecs is a RESOLVED spec dict (get_dict resolves the deflist in its caller's
#context before selecting forms - nothing here touches the caller's frame).
proc private::get_dict_form {argspecs fid rawargs} {
#puts "-arg_info->$arg_info"
set flagsreceived [list] ;#for checking if required flags satisfied
set solosreceived [list]
set multisreceived [list]
#secondary purpose:
#for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default.
#-default value must not be appended to if argname not yet in flagsreceived
#todo: -minmultiple -maxmultiple ?
# -- --- --- ---
# Handle leading positionals
# todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ?
set formdict [dict get $argspecs FORMS $fid]
# formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED
# LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED
# LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES
# OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS
# VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS
# VAL_CHECKS_DEFAULTS FORMDISPLAY
#tcl::dict::with formdict {}
##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
#individual var extraction is faster than 'dict with' - even though we need nearly every key
set ARG_INFO [dict get $formdict ARG_INFO]
set ARG_CHECKS [dict get $formdict ARG_CHECKS]
set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS]
set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED]
set LEADER_NAMES [dict get $formdict LEADER_NAMES]
set LEADER_MIN [dict get $formdict LEADER_MIN]
set LEADER_MAX [dict get $formdict LEADER_MAX]
set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO]
set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED]
set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS]
set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS]
set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS]
set OPT_REQUIRED [dict get $formdict OPT_REQUIRED]
set OPT_NAMES [dict get $formdict OPT_NAMES]
set OPT_ANY [dict get $formdict OPT_ANY]
#set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPT_MASHES [dict get $formdict OPT_MASHES]
set OPT_ALL_MASH_LETTERS [dict get $formdict OPT_ALL_MASH_LETTERS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS]
set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS]
set VAL_REQUIRED [dict get $formdict VAL_REQUIRED]
set VAL_NAMES [dict get $formdict VAL_NAMES]
set VAL_MIN [dict get $formdict VAL_MIN]
set VAL_MAX [dict get $formdict VAL_MAX]
set VAL_UNNAMED [dict get $formdict VAL_UNNAMED]
set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS]
set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS]
set FORMDISPLAY [dict get $formdict FORMDISPLAY]
if {$VAL_MIN eq ""} {
set valmin 0
#set VAL_MIN 0
foreach v $VAL_REQUIRED {
# todo variable clause lengths (items marked optional in types using leading&trailing questionmarks)
# e.g -types {a ?xxx?}
#this has one required and one optional
set clause_length 0
#for each t in typelist
foreach t [dict get $ARG_INFO $v -type] {
if {![string match {\?*\?} $t]} {
incr clause_length
}
}
incr valmin $clause_length
}
} else {
set valmin $VAL_MIN
}
set pre_values {}
set argnames [tcl::dict::keys $ARG_INFO]
#set optnames [lsearch -all -inline $argnames -*]
#JJJ
set lookup_optset [dict create]
foreach optset $OPT_NAMES {
#optset e.g {-x|--longopt|--longopt=|--otherlongopt}
foreach optdef [split $optset |] {
set opt [string trimright $optdef =]
if {![dict exists $lookup_optset $opt]} {
dict set lookup_optset $opt $optset
}
}
}
#note all_opts will necessarily not include mashed flags (e.g -abc) when only -a -b -c are defined - but we will detect and break those down in the main loop below
set all_opts [dict keys $lookup_optset]
set ridx 0
set rawargs_copy $rawargs
set remaining_rawargs $rawargs
set leader_posn_name ""
set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one)
set is_multiple 0 ;#last leader may be multi
#consider for example: LEADER_NAMES {"k v" leader2 leader3} with -type {int number} & -type {int int int} & -type string
#(i.e clause-length of 2 3 and 1)
#This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0
#REVIEW - what about optional members in leaders e.g -type {int ?double?}
set named_leader_args_max 0
foreach ln $LEADER_NAMES {
incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]]
}
#set id [dict get $argspecs id]
#if {$id eq "::if"} {
#puts stderr "::if"
#puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs"
#}
set can_have_leaders 1 ;#default assumption
if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} {
set can_have_leaders 0
}
#REVIEW - this attempt to classify leaders vs opts vs values doesn't account for leaders with clauses containing optional elements
#e.g @leaders {x -type {int ?int?}}
set nameidx 0
if {$can_have_leaders} {
if {$LEADER_TAKEWHENARGSMODULO} {
#assign set of leaders purely based on number of total args
set take [expr {[llength $remaining_rawargs] % $LEADER_TAKEWHENARGSMODULO}]
set pre_values [lrange $remaining_rawargs 0 $take-1]
set remaining_rawargs [lrange $remaining_rawargs $take end]
} else {
#greedy taking of leaders based on type-matching
set leadernames_seen [list]
for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} {
set raw [lindex $rawargs $ridx] ;#received raw arg
if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} {
break
}
if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} {
#at last named leader
set leader_posn_name [lindex $LEADER_NAMES $nameidx]
if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} {
set is_multiple 1
}
} elseif {$ridx > $named_leader_args_max-1} {
#beyond names - retain name if -multiple was true
if {!$is_multiple} {
set leader_posn_name ""
}
} else {
set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string
}
if {$OPT_MAX ne "0" && [string match -* $raw]} {
#all_opts includes end_of_opts marker -- if configured - no need to explicitly check for it separately
set possible_flagname $raw
if {[string match --* $raw]} {
set eposn [string first = $raw]
# --flag=xxx
if {$eposn >=3} {
set possible_flagname [string range $raw 0 $eposn-1]
}
}
set matchopt [::tcl::prefix::match -error {} $all_opts $possible_flagname]
if {$matchopt ne ""} {
#flaglike matches a known flag - don't treat as leader
break
}
}
#for each branch - break or lappend
if {$leader_posn_name ne ""} {
set leader_type [dict get $ARG_INFO $leader_posn_name -type]
#todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words"
set clauselength [llength $leader_type]
set min_clauselength 0
foreach t $leader_type {
if {![string match {\?*\?} $t]} {
incr min_clauselength
}
}
if {$leader_posn_name ni $LEADER_REQUIRED} {
#optional leader
#most adhoc arg processing will allocate based on number of args rather than matching choice values first
#(because a choice value could be a legitimate data value)
#review - option to process in this manner?
#first check if the optional leader value is a match for a choice ?
#if {[dict exists $arg_info $leader_posn_name -choices]} {
# set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] $raw]
# if {$vmatch ne ""} {
# #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values
# lappend pre_values [lpop remaining_rawargs 0]
# incr ridx
# continue
# }
#}
if {[llength $remaining_rawargs] < $min_clauselength} {
#not enough remaining args to fill even this optional leader
#rather than raise error here - perform our break (for end of leaders) and let the code below handle it
break
}
#check if enough remaining_rawargs to fill any required values
if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} {
break
}
#leadername may be a 'clause' of arbitrary length (e.g -type {int double} or {int string number})
set end_leaders 0
set tentative_pre_values [list]
set tentative_idx $ridx
if {$OPT_MAX ne "0"} {
foreach t $leader_type {
set raw [lindex $rawargs $tentative_idx]
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set flagname $raw
if {[string match --* $raw]} {
set eposn [string first = $raw]
# --flag=xxx
if {$eposn >=3} {
set flagname [string range $raw 0 $eposn-1]
}
}
set matchopt [::tcl::prefix::match -error {} $all_opts $flagname]
if {$matchopt ne ""} {
#don't consume if flaglike (and actually matches an opt)
set end_leaders 1
break ;#break out of looking at -type members in the clause
} else {
#unrecognised flag - treat as value for optional member of the clause
#lappend pre_values [lpop remaining_rawargs 0]
lappend tentative_pre_values $raw
incr tentative_idx
}
} else {
#lappend pre_values [lpop remaining_rawargs 0]
lappend tentative_pre_values $raw
incr tentative_idx
}
}
if {$end_leaders} {
break
}
} else {
foreach t $leader_type {
#JJJ
set raw [lindex $rawargs $tentative_idx]
#lappend pre_values [lpop remaining_rawargs 0]
lappend tentative_pre_values $raw
incr tentative_idx
}
}
set assign_d [get_dict_can_assign_value 0 $tentative_pre_values 0 [list $leader_posn_name] $leadernames_seen $formdict]
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {$consumed != 0} {
if {$leader_posn_name ni $leadernames_seen} {
lappend leadernames_seen $leader_posn_name
}
dict incr leader_posn_names_assigned $leader_posn_name
#for {set c 0} {$c < $consumed} {incr c} {
# lappend pre_values [lpop remaining_rawargs 0]
#}
lappend pre_values {*}[lrange $remaining_rawargs 0 $consumed-1]
ledit remaining_rawargs 0 $consumed-1
incr ridx $consumed
incr ridx -1 ;#leave ridx at index of last r that we set
} else {
}
if {!$is_multiple} {
incr nameidx
}
} else {
#clause is required
if {[dict exists $leader_posn_names_assigned $leader_posn_name]} {
#already accepted at least one complete clause for this name - requirement satisfied - now equivalent to optional
if {[llength $remaining_rawargs] < $min_clauselength} {
#not enough remaining args to fill even this optional leader
#rather than raise error here - perform our break (for end of leaders) and let the code below handle it
break
}
if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} {
break
}
}
#if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values
#we still need to check if enough values for the leader itself
if {[llength $remaining_rawargs] < $min_clauselength} {
#not enough remaining args to fill *required* leader
break
}
set end_leaders 0
#review - are we allowing multivalue leader clauses where the optional members are not at the tail?
#eg @leaders {double -type {?int? char}}
#as we don't type-check here while determining leaders vs opts vs values - this seems impractical.
#for consistency and simplification - we should only allow optional clause members at the tail
# and only for the last defined leader. This should be done in the definition parsing - not here.
foreach t $leader_type {
set raw [lindex $rawargs $ridx]
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set matchopt [::tcl::prefix::match -error {} $all_opts $raw]
if {$matchopt ne ""} {
#don't consume if flaglike (and actually matches an opt)
set end_leaders 1
break ;#break out of looking at -type members in the clause
} else {
#unrecognised flag - treat as value for optional member of the clause
#ridx must be valid if we matched -* - so lpop will succeed
lappend pre_values [lpop remaining_rawargs 0]
incr ridx
}
} else {
if {[string match {\?*\?} $t]} {
if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} {
set end_leaders 1
break
}
if {[catch {
lappend pre_values [lpop remaining_rawargs 0]
}]} {
set end_leaders 1
break
}
} else {
if {[catch {
lappend pre_values [lpop remaining_rawargs 0]
}]} {
set end_leaders 1
break ;#let validation of required leaders report the error?
}
}
incr ridx
}
}
incr ridx -1
if {$end_leaders} {
break
}
if {!$is_multiple} {
incr nameidx
}
dict incr leader_posn_names_assigned $leader_posn_name
}
} else {
#unnamed leader
if {$LEADER_MIN ne "" } {
if {$ridx > $LEADER_MIN-1} {
if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} {
break
} else {
if {$valmin > 0} {
if {[llength $remaining_rawargs] > $valmin} {
lappend pre_values [lpop remaining_rawargs 0]
dict incr leader_posn_names_assigned $leader_posn_name
} else {
break
}
} else {
lappend pre_values [lpop remaining_rawargs 0]
dict incr leader_posn_names_assigned $leader_posn_name
}
}
} else {
#haven't reached LEADER_MIN
lappend pre_values [lpop remaining_rawargs 0]
dict incr leader_posn_names_assigned $leader_posn_name
}
} else {
#review - if is_multiple, keep going if enough remaining_rawargs for values?
break
}
}
#incr ridx
} ;# end foreach r $rawargs_copy
}
}
#puts "get_dict ================> pre: $pre_values"
set argstate $ARG_INFO ;#argstate may have entries added
set arg_checks $ARG_CHECKS
if {$LEADER_MIN eq ""} {
set leadermin 0
} else {
set leadermin $LEADER_MIN
}
if {$LEADER_MAX eq ""} {
if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} {
set leadermax 0
} else {
set leadermax -1
}
} else {
set leadermax $LEADER_MAX
}
if {$VAL_MAX eq ""} {
if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} {
set valmax 0
} else {
set valmax -1
}
} else {
set valmax $VAL_MAX
}
#assert leadermax leadermin are numeric
#assert - remaining_rawargs has been reduced by leading positionals
#beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true)
#set opts [dict create] ;#don't set to OPT_DEFAULTS here
set opts [list]
set leaders [list]
set arglist {}
set post_values {}
#valmin, valmax
#puts stderr "remaining_rawargs: $remaining_rawargs"
#puts stderr "argstate: $argstate"
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} {
#contains at least one possible flag
set maxidx [expr {[llength $remaining_rawargs] -1}]
if {$valmax == -1} {
set vals_total_possible [llength $remaining_rawargs]
set vals_remaining_possible $vals_total_possible
} else {
set vals_total_possible $valmax
set vals_remaining_possible $vals_total_possible
}
for {set i 0} {$i <= $maxidx} {incr i} {
set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}]
#lowest valmin is 0
if {$remaining_args_including_this <= $valmin} {
# if current arg is -- it will pass through as a value here
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
set a [lindex $remaining_rawargs $i]
set a1 [string index $a 0]
set a2 [string index $a 1]
if {$a1 eq "-"} {
if {$a2 eq "-"} {
if {$a eq "--"} {
if {"--" in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
} else {
#--*
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
}
}
} else {
#-*
set flagsupplied $a
set flagval ""
set flagval_included false
}
} else {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#switch -glob -- $a {
# -- {
# }
# --* {
# }
# -* {
# }
# default {
# }
#}
#flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
#The prefix matching above doesn't consider that mashed flags can make shorter prefixes an invalid match for the whole flag.
#if the length of our matched flagname is less than the length of $OPT_ALL_MASH_LETTERS, then we may have a mash of other flags,
#not a valid match for some longer flag that just happens to share the same prefix as the start of the mash.
#we have defined valid prefix matches in the presence of mashed flags to be only those that are longer than any possible mash of flags
#(review - for small numbers of mashed flags we could be more precise, but the combinatoric explosion of longer mash lengths makes it
#simpler to just say any match that is shorter than the length of the longest possible mash is invalid
# we may need consider what common utilities do in practice regarding allowing prefixes in the presence of mashed flags
#- but it seems likely that they would either not allow prefixes at all, or only allow prefixes that are longer than any possible mash of flags)
#So if we have a match that isn't exact and is shorter than the length of the longest possible mash, we need to check if it's actually a mash of valid flags rather than a valid prefix match for a longer flag.
if {$flagname ne $flagsupplied && [llength $OPT_MASHES] && (([string length $flagsupplied] -1) <= [llength $OPT_ALL_MASH_LETTERS])} {
#invalidate the match
set flagname ""
}
switch -- $flagname {
-- {
set optionset ""
}
"" {
#no match for flagname - could be a mashed flag e.g -abc where only -a -b -c are defined
if {![llength $OPT_MASHES]} {
#no mashed flags defined - so this probably isn't a flag - could be a value
set optionset ""
} else {
#check if every letter after the first matches a defined opt - if so treat as mashed flags
set mashflags [string range $flagsupplied 1 end]
set mashletters [split $mashflags ""]
set all_mashable true
foreach mf $mashletters {
if {$mf ni $OPT_ALL_MASH_LETTERS} {
set all_mashable false
break
}
}
#todo - move block below up here.
if {!$all_mashable} {
#puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname and not a valid mash of flags - treating as value"
#- probably isn't a flag at all - could be a value
#treat as value
set optionset ""
} else {
#puts stderr "Debug: flagsupplied '$flagsupplied' not a valid flagname but is a valid mash of flags - treating as mash of flags"
#treat as mashed flags - we will break down into individual flags and process each one in turn
set optionset $flagsupplied
#the -mash option means we may have to process multiple flags as received for one arg that looks like a flag
#we can still use the lookup_optset dict to get the optionset for each individual flag - as the keys of lookup_optset are all the individual flags (not mashed together)
#we need to update:
# vals_remaining_possible after processing all matchletters (by -1 or -2 depending on whether the mash includes a flag with an attached value (trailing=<val>) or accepts a value.)
# multisreceived
# soloreceived (if any of the flags in the mash are solo)
# flagsreceived (add the mash as received - but also add each individual flag in the mash as received for the purposes of checking for multiple and solo)
# opts (for each flag in the mash)
set posn 0
set consume_value 0 ;#if last mash flag accepts a value, we will consume the next arg as its value
foreach mf $mashletters {
set matchopt [dict get $lookup_optset -$mf]
if {$matchopt eq ""} {
#this should not happen as we have already checked all letters are mashable - but check just in case
puts stderr "Debug: mash letter '-$mf' not in lookup_optset - this should not happen"
} else {
#process each mashed flag as if it were received separately
#- we can reuse the same flagval for each as they won't be expected to have values (as they are single letter flags)
#we will still need to check for multiple and defaults for each individual flag
#we can also still use the same argstate entries for each individual flag as the optionset will be the same for each of the mashed flags (as they will all be defined in the same optionset e.g -a|-b|-c)
set mashflagname -$mf
set mashflagoptionset [dict get $lookup_optset $mashflagname]
set raw_optionset_members [split $mashflagoptionset |]
#set mashflagapiopt [dict get $argstate $mashflagoptionset -parsekey]
#if {$mashflagapiopt eq ""} {
# set mashflagapiopt [string trimright [lindex [split $mashflagoptionset |] end] =]
#}
set flagname -$mf
if {[tcl::dict::get $argstate $mashflagoptionset -parsekey] ne ""} {
set api_opt [dict get $argstate $mashflagoptionset -parsekey]
} else {
set api_opt [string trimright [lindex $raw_optionset_members end] =]
}
if {$api_opt eq $flagname} {
set flag_ident $api_opt
set flag_ident_is_parsekey 0
} else {
#initially key our opts on a long form allowing us to know which specific flag was used
#(for when multiple map to same parsekey e.g lsearch)
#e.g -increasing|-SORTOPTION
set flag_ident $flagname|$api_opt
set flag_ident_is_parsekey 1
}
set optionset_type [tcl::dict::get $argstate $mashflagoptionset -type]
#only the last flag in a mash can be allowed to have a value, and the other flags must be of type none.
#flags are by default optional.
if {$optionset_type ne "none"} {
#A flag with a value - only allowed for the last flag in a mash
if {$posn != [expr {[llength $mashletters] - 1}]} {
#not the last flag in the mash - can't have a value
set errmsg "bad options for %caller%. Flag \"$mashflagname\" in mash \"$flagsupplied\" cannot have a value as only the last flag in a mash can have a value. The flag \"$mashflagname\" must be of type none. (1)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg
} else {
set consume_value 1
# ------------
#check if it was actually a value that looked like a flag
if {$i == $maxidx} {
#if no optvalue following - assume it's a value
#(caller should probably have used -- before it)
#review
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#flagval comes from next remaining rawarg
set flagval [lindex $remaining_rawargs $i+1]
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#don't lappend to default - we need to replace if there is a default
if {$api_opt ni $flagsreceived} {
tcl::dict::set opts $flag_ident [list $flagval]
} else {
tcl::dict::lappend opts $flag_ident $flagval
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
}
}
#incr i to skip flagval
#incr vals_remaining_possible -2
#if {[incr i] > $maxidx} {
# set msg "Bad options for %caller%. No value supplied for last option $mashflagoptionset at index [expr {$i-1}] which is not marked with -type none"
# return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $mashflagoptionset index [expr {$i-1}]] -badarg $mashflagoptionset -argspecs $argspecs]] $msg
#}
# ------------
}
} else {
#flag with no value - check for -typedefaults for the flag
#none / solo
if {[tcl::dict::exists $argstate $mashflagoptionset -typedefaults]} {
set tdflt [tcl::dict::get $argstate $mashflagoptionset -typedefaults]
} else {
#normal default for a solo is 1 unless overridden by -typedefaults
set tdflt 1
}
if {[tcl::dict::get $argstate $mashflagoptionset -multiple]} {
#puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' is a multiple with typedefaults $tdflt -- api_opt: $api_opt flag_ident: $flag_ident flagsreceived: $flagsreceived multisreceived: $multisreceived"
if {$api_opt ni $flagsreceived} {
#override any default - don't lappend to it
tcl::dict::set opts $flag_ident $tdflt
} else {
tcl::dict::lappend opts $flag_ident $tdflt
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}
#tcl::dict::set opts $flag_ident $tdflt
if {$flag_ident_is_parsekey} {
#(shimmer - but required for ordering correctness during override)
#puts stderr "Debug: flag '$mashflagname' in mash '$flagsupplied' flag_ident '$flag_ident' is the same as parsekey '$api_opt' tdflt: $tdflt - using lappend to ensure it ends up after any previous flag in the mash that had the same parsekey"
lappend opts $flag_ident $tdflt
} else {
tcl::dict::set opts $flag_ident $tdflt
}
}
#incr vals_remaining_possible -1
lappend solosreceived $api_opt ;#dups ok
}
}
lappend flagsreceived $api_opt
incr posn
}
#update vals_remaining_possible by one or 2 if the last flag took a value.
incr vals_remaining_possible -1
if {$flagval_included || $consume_value} {
incr vals_remaining_possible -1
}
#after processing the mash, we will have updated opts for each individual flag in the mash,
#and updated multisreceived and solo_received as needed based on the optionset entries for each individual flag in the mash
#we possibly need to incr i to skip a received value for the mash if the last flag in the mash had a value.
#or break if we have reached the end of the args after processing the mash
if {$flagval_included || $consume_value} {
#the last flag in the mash had a value - we have already processed it for that flag - so we need to skip it for the next iteration of the loop
incr i
if {$i > $maxidx} {
#we have reached the end of the args after processing the mash and its value - so we can break out of the loop
break
}
} else {
#no value included for the last flag in the mash - so we just continue to the next iteration of the loop to process the next arg
}
continue
}
}
}
default {
if {[dict exists $lookup_optset $flagname]} {
set optionset [dict get $lookup_optset $flagname]
} else {
#we matched a prefix of all_opts - but it's not in the lookup_optset?
#review - this should not happen as we only match prefixes from all_opts which is derived from the keys of lookup_optset
puts stderr "Debug: matched prefix '$flagname' not in lookup_optset - this should not happen"
set optionset ""
}
}
}
if {$optionset ne ""} {
#matched some option - either in part or in full.
set raw_optionset_members [split $optionset |]
#check the specific flagname is allowed to have =
if {$flagval_included && "$flagname=" ni $raw_optionset_members} {
set errmsg "bad options for %caller%. Unexpected option \"$flagname=\": must be one of: $all_opts (--longopt= not specified) (1)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg
}
#e.g when optionset eq -fg|-foreground
#-fg is an alias , -foreground is the 'api' value for the result dict
#$optionset remains as the key in the spec
#set optmembers [list]
#foreach optspec [split $optionset |] {
# set o [string trimright $optspec =]
# if {$o ni $optmembers} {
# lappend optmembers $o
# }
#}
#set parsekey [lindex $optmembers end]
if {[tcl::dict::get $argstate $optionset -parsekey] ne ""} {
set api_opt [dict get $argstate $optionset -parsekey]
} else {
set api_opt [string trimright [lindex $raw_optionset_members end] =]
}
if {$api_opt eq $flagname} {
set flag_ident $api_opt
set flag_ident_is_parsekey 0
} else {
#initially key our opts on a long form allowing us to know which specific flag was used
#(for when multiple map to same parsekey e.g lsearch)
#e.g -increasing|-SORTOPTION
set flag_ident $flagname|$api_opt
set flag_ident_is_parsekey 1
}
if {![tcl::dict::get $argstate $optionset -prefix] && $flagsupplied ni $all_opts} {
#attempt to use a prefix when not allowed
#review - by ending opts here - we dont' get the clearest error msgs
# may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error
# (but it may actually be the first value that just happens to be flaglike)
#todo - check for subsequent valid flags or -- marker?
#consider for example 'file delete -f -- old.txt'
#If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values
#whereas the builtin file arg parser alerts that -f is a bad option
set errmsg "bad options for %caller%. Unexpected option \"$flagname\": must be one of: $all_opts (2)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg
#set arglist [lrange $remaining_rawargs 0 $i-1]
#set post_values [lrange $remaining_rawargs $i end]
#break
}
set optionset_type [tcl::dict::get $argstate $optionset -type]
if {$optionset_type ne "none"} {
#non-solo (but type could still be optional ?type?)
if {$flagval_included} {
#longopt with value e.g --longopt=x
#flagval is already set
if {[tcl::dict::get $argstate $optionset -multiple]} {
#don't lappend to default - we need to replace if there is a default
if {$api_opt ni $flagsreceived} {
tcl::dict::set opts $flag_ident [list $flagval]
} else {
tcl::dict::lappend opts $flag_ident $flagval
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
if {$flag_ident_is_parsekey} {
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
}
}
} else {
#disallow "--longopt val" if only --longopt= was in optionset
#but we need to process "--longopt etc whatever..." as solo if 'optional' (?type?)
set solo_only false
if {[string match {\?*\?} $optionset_type]} {
#optional type
if {"$flagname=" ni $raw_optionset_members} {
set solo_only true
} else {
#--longopt= is present
if {"$flagname" ni $raw_optionset_members} {
#only parsing "--flag" or "--flag=val" is allowed by configuration -types ?type?
#we are in !$flagval_included branch so only solo left
#
set solo_only true
}
}
} else {
#flag value is non-optional
#no solo allowed
#--longopt= alone does not allow --longopt <val> usage
if {$flagname ni $raw_optionset_members} {
#
set msg "Bad options for %caller%. Option $optionset at index [expr {$i-1}] requires a value, but '$flagname' not specified in definition to allow space-separated value."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list badoptionformat $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg
}
}
if {$solo_only} {
#same logic as 'solo' branch below for -type none
if {[tcl::dict::exists $argstate $optionset -typedefaults]} {
set tdflt [tcl::dict::get $argstate $optionset -typedefaults]
} else {
#normal default for a solo is 1 unless overridden by -typedefaults
set tdflt 1
}
if {[tcl::dict::get $argstate $optionset -multiple]} {
if {$api_opt ni $flagsreceived} {
#override any default - don't lappend to it
tcl::dict::set opts $flag_ident $tdflt
} else {
tcl::dict::lappend opts $flag_ident $tdflt
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
if {$flag_ident_is_parsekey} {
lappend opts $flag_ident $tdflt
} else {
tcl::dict::set opts $flag_ident $tdflt
}
}
incr vals_remaining_possible -1
lappend solosreceived $api_opt ;#dups ok
} else {
#check if it was actually a value that looked like a flag
if {$i == $maxidx} {
#if no optvalue following - assume it's a value
#(caller should probably have used -- before it)
#review
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#flagval comes from next remaining rawarg
set flagval [lindex $remaining_rawargs $i+1]
if {[tcl::dict::get $argstate $optionset -multiple]} {
#don't lappend to default - we need to replace if there is a default
if {$api_opt ni $flagsreceived} {
tcl::dict::set opts $flag_ident [list $flagval]
} else {
tcl::dict::lappend opts $flag_ident $flagval
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
}
}
#incr i to skip flagval
incr vals_remaining_possible -2
if {[incr i] > $maxidx} {
set msg "Bad options for %caller%. No value supplied for last option $optionset at index [expr {$i-1}] which is not marked with -type none"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg
}
}
}
} else {
#none / solo
if {[tcl::dict::exists $argstate $optionset -typedefaults]} {
set tdflt [tcl::dict::get $argstate $optionset -typedefaults]
} else {
#normal default for a solo is 1 unless overridden by -typedefaults
set tdflt 1
}
if {[tcl::dict::get $argstate $optionset -multiple]} {
if {$api_opt ni $flagsreceived} {
#override any default - don't lappend to it
tcl::dict::set opts $flag_ident $tdflt
} else {
tcl::dict::lappend opts $flag_ident $tdflt
}
if {$api_opt ni $multisreceived} {
lappend multisreceived $api_opt
}
} else {
#test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence}
#tcl::dict::set opts $flag_ident $tdflt
if {$flag_ident_is_parsekey} {
#(shimmer - but required for ordering correctness during override)
lappend opts $flag_ident $tdflt
} else {
tcl::dict::set opts $flag_ident $tdflt
}
}
incr vals_remaining_possible -1
lappend solosreceived $api_opt ;#dups ok
}
lappend flagsreceived $api_opt ;#dups ok
} else {
#starts with - but unmatched option flag
#comparison to valmin already done above
if {$valmax ne -1 && $remaining_args_including_this <= $valmax} {
#todo - look at optspec_default and see if solo/vs opt-val pair
#we may need to lookahead by 2 regarding valmax valmin
#even if optany - assume an unknown within the space of possible values is a value
#unmatched option in right position to be considered a value - treat like eopts
#review - document that an unspecified arg within range of possible values will act like eopts --
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} {
if {$OPT_ANY} {
#exclude argument with whitespace from being a possible option e.g dict
#todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value
set eposn [string first = $a]
if {$eposn > 2 && [string match --* $a]} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#undefined_flagsupplied may still be a 'short form/prefix'
set undefined_flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
} else {
set undefined_flagsupplied $a
set flagval ""
set flagval_included false
}
if {$flagval_included} {
tcl::dict::set argstate $undefined_flagsupplied $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt
tcl::dict::set arg_checks $undefined_flagsupplied $OPT_CHECKS_DEFAULTS
if {[tcl::dict::get $argstate $undefined_flagsupplied -multiple]} {
tcl::dict::lappend opts $undefined_flagsupplied $flagval
if {$undefined_flagsupplied ni $multisreceived} {
lappend multisreceived $undefined_flagsupplied
}
} else {
tcl::dict::set opts $undefined_flagsupplied $flagval
}
incr vals_remaining_possible -1
} else {
set flagval [lindex $remaining_rawargs $i+1]
#opt was unspecified but is allowed due to @opts -any|-arbitrary true - 'adhoc/passthrough' option
tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt
tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS
#assert -type value has llength 1 (multitype clauses not allowed for opts)
if {[tcl::dict::get $argstate $a -type] ne "none"} {
if {[tcl::dict::get $argstate $a -multiple]} {
tcl::dict::lappend opts $a $flagval
if {$a ni $multisreceived} {
lappend multisreceived $a
}
} else {
tcl::dict::set opts $a $flagval
}
if {[incr i] > $maxidx} {
set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg
#arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a
}
incr vals_remaining_possible -2
} else {
#review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none
if {[tcl::dict::exists $argstate $a -typedefaults]} {
set tdflt [tcl::dict::get $argstate $a -typedefaults]
} else {
set tdflt 1
}
if {[tcl::dict::get $argstate $a -multiple]} {
if {![tcl::dict::exists $opts $a]} {
tcl::dict::set opts $a $tdflt
} else {
tcl::dict::lappend opts $a $tdflt
}
if {$a ni $multisreceived} {
lappend multisreceived $a
}
} else {
tcl::dict::set opts $a $tdflt
}
incr vals_remaining_possible -1
lappend solosreceived $a
}
}
lappend flagsreceived $undefined_flagsupplied ;#adhoc flag name (if --x=1 -> --x)
} else {
if {[llength $OPT_NAMES]} {
set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES (3)"
} else {
set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any|-arbitrary false"
}
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg
#arg_error $errmsg $argspecs -badarg $optionset
}
} else {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
}
}
#set values [list {*}$pre_values {*}$post_values]
set leaders $pre_values
set values $post_values
} else {
set leaders $pre_values
set values $remaining_rawargs
#set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected
set arglist [list]
}
#set id [dict get $argspecs id]
#if {$id eq "::if"} {
#puts stderr "::if"
#puts stderr "get_dict--> arglist: $arglist"
#puts stderr "get_dict--> leaders: $leaders"
#puts stderr "get_dict--> values: $values"
#}
#---------------------------------------
#Order the received options by the order in which they are *defined*
#EXCEPT that grouped options using same parsekey must be processed in received order
set ordered_opts [dict create]
#set unaliased_opts [lmap v $OPT_NAMES {string trimright [lindex [split $v |] end] =}]
##unaliased_opts is list of 'api_opt' (to handle flag aliases of form -a1|-a2|-api_opt)
## e.g -fg|-foreground
## e.g -x|--fullname=
##Resulting unaliased_opts from list {-fg|-foreground -x|--fullname=} should be {-foreground --fullname}
#foreach o $unaliased_opts optset $OPT_NAMES {
# if {[dict exists $opts $o]} {
# dict set ordered_opts $o [dict get $opts $o]
# } elseif {[dict exists $OPT_DEFAULTS $optset]} {
# #JJJ
# set parsekey ""
# if {[tcl::dict::exists $argstate $o -parsekey]} {
# set parsekey [tcl::dict::get $argstate $o -parsekey]
# }
# if {$parsekey eq ""} {
# set parsekey $o
# }
# dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset]
# }
#}
#puts ">>>>====opts: $opts"
set seen_pks [list]
#treating opts as list for this loop.
foreach optset $OPT_NAMES {
set parsekey ""
#set has_parsekey_override 0
if {[tcl::dict::exists $argstate $optset -parsekey]} {
set parsekey [tcl::dict::get $argstate $optset -parsekey]
}
if {$parsekey eq ""} {
#set has_parsekey_override 0
#fall back to last element of aliased option e.g -fg|-foreground -> "-foreground"
set parsekey [string trimright [lindex [split $optset |] end] =]
} else {
#set has_parsekey_override 1
}
lappend seen_pks $parsekey
set is_found 0
set foundkey ""
set foundval ""
#no lsearch -stride avail in 8.6
foreach {k v} $opts {
if {$k eq $parsekey} {
set foundkey $k
set is_found 1
set foundval $v
#can be multiple - last match wins - don't 'break' out of foreach
}
} ;#avoiding further dict/list shimmering
#if {[dict exists $opts $parsekey]} {
# set found $parsekey
# set foundval [dict get $opts $parsekey]
#}
if {!$is_found && $parsekey ne $optset} {
#.g we may have in opts things like: -decreasing|-SORTDIRECTION -increasing|-SORTDIRECTION
#(where -SORTDIRECTION was configured as -parsekey)
#last entry must win
#NOTE - do not use dict for here. opts is not strictly a dict - dupe keys will cause wrong ordering
foreach {o v} $opts {
if {[string match *|$parsekey $o]} {
set foundkey $o
set is_found 1
set foundval $v
#last match wins - don't 'break' out of foreach
}
}
}
if {$is_found} {
dict set ordered_opts $foundkey $foundval
} elseif {[tcl::dict::exists $OPT_DEFAULTS $optset]} {
if {$parsekey ne $optset} {
set tailopt [string trimright [lindex [split $optset |] end] =]
if {$tailopt ne $parsekey} {
#defaults for multiple options sharing a -parsekey value ? review
dict set ordered_opts $tailopt|$parsekey [dict get $OPT_DEFAULTS $optset]
} else {
dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset]
}
} else {
dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset]
}
}
}
#add in possible arbitrary opts after the defined opts, due to @opts directive flag '-any|-arbitrary true'
#But make sure not to add any repeated parsekey e.g -increasing|-SORT -decreasing|-SORT
#use the seen_pks from the ordered_opts loop above
#keep working with opts only as list here..
if {[llength $opts] > 2*[dict size $ordered_opts]} {
foreach {o o_val} $opts {
lassign [split $o |] _ parsekey ;#single pipe - 2 elements only <fullflagformofflagused>|<parsekey>
if {$parsekey ne "" && $parsekey in $seen_pks} {
continue
}
if {![dict exists $ordered_opts $o]} {
dict set ordered_opts $o $o_val
}
}
}
set opts $ordered_opts
#opts is a proper dict now
#NOTE opts still may contain some entries in non-final form such as -flag|-PARSEKEY
#---------------------------------------
set positionalidx 0 ;#index for unnamed positionals (both leaders and values)
set leadername_multiple ""
set leadernames_received [list]
set num_leaders [llength $leaders]
#----------------------------------------
#Establish firm leaders ordering
set leaders_dict [dict create]
foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] {
dict set leaders_dict $lname {}
}
set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS]
#----------------------------------------
set argument_clause_typestate [dict create] ;#Track *updated* -type info for argument clauses for those subelements that were fully validated during private::get_dict_can_assign_value
set start_position $positionalidx
set nameidx 0
#MAINTENANCE - (*nearly*?) same loop logic as for value
for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} {
set leadername [lindex $LEADER_NAMES $nameidx]
set ldr [lindex $leaders $ldridx]
if {$leadername ne ""} {
set leadertypelist [tcl::dict::get $argstate $leadername -type] ;#often a single type, but can be a list of types (possibly with some optional) for a type that is a clause accepting multiple values.
set leader_clause_size [llength $leadertypelist]
set assign_d [get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict]
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {$consumed == 0} {
if {[tcl::dict::get $argstate $leadername -optional]} {
#puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)"
#return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "private::get_dict_can_assign_value consumed 0 unexpected 1?"
incr ldridx -1
set leadername_multiple ""
incr nameidx
continue
} else {
#required named arg
if {$leadername ni $leadernames_received} {
#puts stderr "private::get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES"
set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredleader $leadername ] -badarg $leadername -argspecs $argspecs]] $msg
} else {
#puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername (222)"
#return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "private::get_dict_can_assign_value consumed 0 unexpected 2?"
incr ldridx -1
set leadername_multiple ""
incr nameidx
continue
}
}
}
if {$leader_clause_size == 1} {
#set clauseval $ldr
set clauseval [lindex $resultlist 0]
} else {
set clauseval $resultlist
incr ldridx [expr {$consumed - 1}]
#not quite right.. this modifies the -type for all clauses with this name - but for -multiple true each instance should really be considered separately.
#e.g when a subelement-containing clause is allowed to appear multiple times (-multiple true)
# - we may hava a situation where the supplied arguments do and don't omit optional subelements,
# and the newtypelist from one clause may overwrite the newtypelist from the other clause where the optional subelement was omitted in one arg, but not in the other arg.
# - if expr {} elseif 2 {script2} elseif 3 then {script3}
# - (where elseif clause defined as "literal(elseif) expr ?literal(then)? script")
# The elseif 2 {script2} will reassign the type as "literal(elseif) expr ?omitted-literal(then)? script"
# when the elseif 3 then {script3} is processed, 'then' is now considered against the type ?ommitted-literal(then)?
#which (as a non-recognised type is therefore not validated ) will then
# allow any value instead of 'then' to pass.
#see argument_clause_typestate in value processing loop below for more handling of this issue regarding -multiple true clauses with optional subelements
#todo - synchronize with value processing loop below
#- consider refactor to a common procedure for handling this issue of tracking updated typelist state for optional subelements in -multiple true clauses
#incorrect -don't update default -type info.
#tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? entries
}
if {[tcl::dict::get $argstate $leadername -multiple]} {
#if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} {
# #current stored ldr equals defined default - don't include default in the list we build up
# tcl::dict::set leaders_dict $leadername [list $clauseval] ;#important to treat first element as a list
#} else {
# tcl::dict::lappend leaders_dict $leadername $clauseval
#}
if {$leadername in $leadernames_received} {
tcl::dict::lappend leaders_dict $leadername $clauseval
tcl::dict::lappend argument_clause_typestate $leadername $newtypelist
} else {
tcl::dict::set leaders_dict $leadername [list $clauseval]
tcl::dict::set argument_clause_typestate $leadername [list $newtypelist]
}
set leadername_multiple $leadername
} else {
tcl::dict::set leaders_dict $leadername $clauseval
tcl::dict::set argument_clause_typestate $leadername [list $newtypelist]
set leadername_multiple ""
incr nameidx
}
lappend leadernames_received $leadername
} else {
if {$leadername_multiple ne ""} {
set leadertypelist [tcl::dict::get $argstate $leadername_multiple -type]
if {[llength $leadertypelist] == 1} {
set clauseval $ldr
} else {
set clauseval [list]
incr ldridx -1
foreach t $leadertypelist {
incr ldridx
if {$ldridx > [llength $leaders]-1} {
set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername_multiple', but requires up to [llength $leadertypelist] values."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadertypelist] ] -argspecs $argspecs]] $msg
}
lappend clauseval [lindex $leaders $ldridx]
}
}
tcl::dict::lappend leaders_dict $leadername_multiple $clauseval
#name already seen - but must add to leadernames_received anyway (as with opts and values)
lappend leadernames_received $leadername_multiple
} else {
if {$LEADER_UNNAMED} {
tcl::dict::set leaders_dict $positionalidx $ldr
tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS
tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS
lappend leadernames_received $positionalidx
} else {
set msg "Bad number of leaders for %caller%. Received more leaders than can be assigned to argument names. (set '@leaders -unnamed true' to allow unnamed leaders)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg
}
}
}
set positionalidx [expr {$start_position + $ldridx + 1}]
}
#-----------------------------------------------------
#satisfy test parse_withdef_leaders_no_phantom_default
#foreach leadername [dict keys $leaders_dict] {
# if {[string is integer -strict $leadername]} {
# #ignore leadername that is a positionalidx
# #review - always trailing - could use break?
# continue
# }
# if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} {
# #remove the name with empty-string default we used to establish fixed order of names
# #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
# dict unset leaders_dict $leadername
# }
#}
dict for {leadername _v} $leaders_dict {
if {[string is integer -strict $leadername]} {
#ignore leadername that is a positionalidx
#review - always trailing - could use break?
continue
}
if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset leaders_dict $leadername
}
}
#-----------------------------------------------------
set validx 0
set valname_multiple ""
set valnames_received [list]
#xxxxxxxxxxxxxxxxxx
set api_valnames_received [list]
#xxxxxxxxxxxxxxxxxx
set num_values [llength $values]
#------------------------------------------
#Establish firm values ordering
## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults
## set values_dict $val_defaults
set values_dict [dict create]
foreach valname [lrange $VAL_NAMES 0 $num_values-1] {
#set ALL valnames to lock in positioning
#note - later we need to unset any optional that had no default and was not received (no phantom default)
dict set values_dict $valname {}
}
set values_dict [dict merge $values_dict $VAL_DEFAULTS]
#------------------------------------------
set nameidx 0
set start_position $positionalidx
set seen_pks [list]
#MAINTENANCE - (*nearly*?) same loop logic as for leaders
for {set validx 0} {$validx < [llength $values]} {incr validx} {
set valname [lindex $VAL_NAMES $nameidx]
set val [lindex $values $validx]
#----------------------------------
#todo
set api_valname ""
if {[tcl::dict::exists $argstate $valname -parsekey]} {
set api_valname [tcl::dict::get $argstate $valname -parsekey]
}
if {$api_valname eq ""} {
#parsekey is the same as valname
set api_valname $valname
}
if {$api_valname eq $valname} {
#if parsekey is the same as valname, we can just use valname as the identifier for opts and values
set val_ident $valname
set val_ident_is_parsekey 0
} else {
#initially key our values on a long form allowing us to know which specific value position was used (for when multiple map to same parsekey)
#e.g -increasing|-SORTOPTION
set val_ident $valname|$api_valname
set val_ident_is_parsekey 1
}
lappend seen_pks $api_valname
#----------------------------------
#xxxxxxxxxxxxxxxxxxxxx
# if {[tcl::dict::get $argstate $optionset -parsekey] ne ""} {
# set api_opt [dict get $argstate $optionset -parsekey]
# } else {
# set api_opt [string trimright [lindex $raw_optionset_members end] =]
# }
# if {$api_opt eq $flagname} {
# set flag_ident $api_opt
# set flag_ident_is_parsekey 0
# } else {
# #initially key our opts on a long form allowing us to know which specific flag was used
# #(for when multiple map to same parsekey e.g lsearch)
# #e.g -increasing|-SORTOPTION
# set flag_ident $flagname|$api_opt
# set flag_ident_is_parsekey 1
# }
#xxxxxxxxxxxxxxxxxxxxx
if {$valname ne ""} {
set valtypelist [tcl::dict::get $argstate $valname -type]
set clause_size [llength $valtypelist] ;#common case is clause_size == 1
set assign_d [get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict]
set consumed [dict get $assign_d consumed] ;#count
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {$consumed == 0} {
if {[tcl::dict::get $argstate $valname -optional]} {
#error 333
#puts stderr "get_dict cannot assign val:$val to valname:$valname (333)"
incr validx -1
set valname_multiple ""
incr nameidx
continue
} else {
#required named arg
if {$valname ni $valnames_received} {
#puts stderr "private::get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES"
set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -badarg $valname -argspecs $argspecs]] $msg
} else {
#error 444
#puts stderr "get_dict cannot assign val:$val to valname:$valname (444)"
incr validx -1
set valname_multiple ""
incr nameidx
continue
}
}
}
#assert can_assign != 0, we have at least one value to assign to clause
if {$clause_size == 1} {
#set clauseval $val
set clauseval [lindex $resultlist 0]
} else {
#clauseval must contain as many elements as the max length of -types!
#(empty-string/default for optional (?xxx?) clause members)
set clauseval $resultlist
#_get_dict_can_assign has only validated clause-length and literals match
#we assign and leave further validation for main validation loop.
incr validx [expr {$consumed -1}]
if {$validx > [llength $values]-1} {
error "get_dict unreachable"
set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to $clause_size values."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength $clause_size ] -argspecs $argspecs]] $msg
}
#incorrect - we shouldn't update the default. see argument_clause_typestate dict of lists of -type
#tcl::dict::set argstate $valname -type $newtypelist ;#(possible ?omitted-<type>? and ?defaulted-<type>? and ?validated-<type>? entries
}
if {[tcl::dict::get $argstate $valname -multiple]} {
#if {[tcl::dict::exists $VAL_DEFAULTS $valname]} {
# #current stored val equals defined default - don't include default in the list we build up
# tcl::dict::set values_dict $valname [list $clauseval] ;#important to treat first element as a list
#} else {
# tcl::dict::lappend values_dict $valname $clauseval
#}
if {$valname in $valnames_received} {
tcl::dict::lappend values_dict $valname $clauseval
tcl::dict::lappend argument_clause_typestate $valname $newtypelist
} else {
tcl::dict::set values_dict $valname [list $clauseval]
tcl::dict::set argument_clause_typestate $valname [list $newtypelist]
}
set valname_multiple $valname
} else {
tcl::dict::set values_dict $valname $clauseval
tcl::dict::set argument_clause_typestate $valname [list $newtypelist] ;#list protect
set valname_multiple ""
incr nameidx
}
lappend valnames_received $valname
lappend api_valnames_received $api_valname
} else {
#unnamed
if {$valname_multiple ne ""} {
set valtypelist [tcl::dict::get $argstate $valname_multiple -type]
if {[llength $valname_multiple] == 1} {
set clauseval $val
} else {
set clauseval [list]
incr validx -1
for {set i 0} {$i < [llength $valtypelist]} {incr i} {
incr validx
if {$validx > [llength $values]-1} {
set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname_multiple', but requires [llength $valtypelist] values."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg
}
lappend clauseval [lindex $values $validx]
}
}
tcl::dict::lappend values_dict $valname_multiple $clauseval
#name already seen - but must add to valnames_received anyway (as with opts and leaders)
lappend valnames_received $valname_multiple
} else {
if {$VAL_UNNAMED} {
tcl::dict::set values_dict $positionalidx $val
tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS
tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS
lappend valnames_received $positionalidx
} else {
set msg "Bad number of values for %caller%. Received more values than can be assigned to argument names. (set '@values -unnamed true' to allow unnamed values)"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg
}
}
}
set positionalidx [expr {$start_position + $validx + 1}]
}
#-----------------------------------------------------
#satisfy test parse_withdef_values_no_phantom_default
foreach vname [dict keys $values_dict] {
if {[string is integer -strict $vname]} {
#ignore vname that is a positionalidx
#review - always trailing - could break?
continue
}
if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset values_dict $vname
}
}
#-----------------------------------------------------
#JJJJJJ
#if {[dict size $argument_clause_typestate]} {
# puts ">>>>>[dict get $argspecs id] typestate $argument_clause_typestate"
#}
if {$leadermax == -1} {
#only check min
if {$num_leaders < $leadermin} {
set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg
}
} else {
if {$num_leaders < $leadermin || $num_leaders > $leadermax} {
if {$leadermin == $leadermax} {
set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg
} else {
set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg
}
}
}
if {$valmax == -1} {
#only check min
if {$num_values < $valmin} {
set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg
}
} else {
if {$num_values < $valmin || $num_values > $valmax} {
if {$valmin == $valmax} {
set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg
} else {
set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg
}
}
}
#assertion - opts keys are full-length option names if -any|-arbitrary was false or if the supplied option as a shortname matched one of our defined options
#(and may still contain non-final flag_ident entries such as -increasing|-SORTDIRECTION)
#opts explicitly marked as -optional 0 must be present - regardless of -any|-arbitrary (which allows us to ignore additional opts to pass on to next call)
#however - if -any|-arbitrary is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call
#We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW
#The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function.
#without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level
#For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true
#safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly?
#example timing difference:
#struct::set difference {x} {a b}
#normal interp 0.18 u2 vs safe interp 9.4us
#if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} {
# error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form"
#}
#if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} {
# error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present"
#}
#for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us
if {[llength $LEADER_REQUIRED]} {
if {[llength [set missing [punk::args::system::punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} {
set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg
#arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
}
}
if {[llength $OPT_REQUIRED]} {
#broken e.g
#punk::args::define {@id -id ::spud} @opts {-x -parsekey -coord -optional 0} {-y -parsekey -coord -optional 0}
#error is:
#Required option missing for punk::args::parse {-x 1 -y 1} withid ::spud. missing flags: '-x -y' are marked with -optional false - so must be present. flags received: '-coord -coord'
set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}]
if {[llength [set missing [punk::args::system::punklib_ldiff $api_opt_required $flagsreceived]]]} {
set full_missing [list]
foreach m $missing {
if {[dict exists $lookup_optset $m]} {
lappend full_missing [dict get $lookup_optset $m]
} else {
lappend full_missing $m
}
}
#set full_missing [dict get $lookup_optset $missing]
set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present. flags received: '$flagsreceived'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg
#arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs
}
}
if {[llength $VAL_REQUIRED]} {
if {[llength [set missing [punk::args::system::punklib_ldiff $VAL_REQUIRED $valnames_received]]]} {
set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg
#arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs
}
}
#---------------------------------------------------------------------------------------------
#maintain order of opts $opts values $values as caller may use lassign.
set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received]
if {[llength $receivednames]} {
#flat zip of names with overall posn, including opts
#set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]]
set i -1
set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]]
} else {
set received_posns [list]
}
#Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value)
#(e.g using 'dict exists $received -flag')
# - but it can have duplicate keys when args/opts have -multiple 1
#It is actually a list of paired elements
#---------------------------------------------------------------------------------------------
#todo - truncate/summarize values in error messages
#todo - allow defaults outside of choices/ranges
#check types,ranges,choices
set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict]
#set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash
#puts "get_dict>>>>>>>> ---opts_and_values:$opts_and_values"
#puts " >>>>>>> ---lookup_optset :$lookup_optset"
#puts "---argstate:$argstate"
#JJJ argname_or_ident; ident example: -increasing|-SORTOPTION
#review - ensure all possible keys present in thisarg_keys
#set pkoverride [Dict_getdef $argstate -parsekey ""]
set pkoverride ""
tcl::dict::for {argname_or_ident value_group} $opts_and_values {
#
#parsekey: key used in resulting leaders opts values dictionaries
# often distinct from the full argname in the ARG_INFO structure
#
if {[string match -* $argname_or_ident]} {
#ident format only applies to options/flags
if {[string first | $argname_or_ident] > -1} {
#flag_ident style (grouped fullname of option with -parsekey)
lassign [split $argname_or_ident |] fullflag parsekey ;#we expect only a single pipe in ident form <fullflag>|<parsekey>
if {[dict exists $lookup_optset $fullflag]} {
set argname [dict get $lookup_optset $fullflag]
#idents should already have correct parsekey
} else {
#adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset.
#argstate/arg_checks were populated for it under its raw supplied name at scan time.
set argname $fullflag
#puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)"
}
} else {
if {[dict exists $lookup_optset $argname_or_ident]} {
#get full option name such as -fg|-foreground from non-alias name such as -foreground
#if "@opts -any|-arbitrary true" - we may have an option that wasn't defined
set argname [dict get $lookup_optset $argname_or_ident]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
#default parsekey: last element in argname without trailing =
set parsekey [string trimright [lindex [split $argname |] end] =]
}
} else {
#adhoc option (allowed via "@opts -any|-arbitrary true") - not in lookup_optset.
#argstate/arg_checks were populated for it under its raw supplied name at scan time.
set argname $argname_or_ident
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
set parsekey [string trimright [lindex [split $argname |] end] =]
}
#puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)"
}
}
} else {
#leader or value.
set argname $argname_or_ident
#set pkoverride [Dict_getdef $argstate $argname -parsekey ""]
#TODO?
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
#leader or value of form x|y has no special meaning and forms the parsekey in entirety by default.
set parsekey $argname
}
}
#assert: argname is the key for the relevant argument info in the FORMS/<name>/ARG_INFO dict. (here each member available as $argstate)
#argname is usually the full name as specified in the definition:
#e.g -f|-path|--filename=
# (where the parsekey will be by default --filename, possibly overridden by -parsekey value)
#an example argname_or_compound for the above might be: -path|--filename
# where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey
set thisarg_checks [tcl::dict::get $arg_checks $argname]
set thisarg [tcl::dict::get $argstate $argname]
#set thisarg_keys [tcl::dict::keys $thisarg]
#using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict
set typelist [tcl::dict::get $thisarg -type]
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 validationtransform [tcl::dict::get $thisarg -validationtransform]
set has_default [tcl::dict::exists $thisarg -default]
if {$has_default} {
set defaultval [tcl::dict::get $thisarg -default]
}
set clause_size [llength $typelist]
set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}]
#JJJJ
#if {$is_multiple} {
# set vlist $value_group
#} else {
# set vlist [list $value_group]
#}
##JJJJ
#if {$clause_size == 1} {
# set vlist [list $vlist]
#}
#JJ 2025-07-25
set vlist [list]
#vlist is a list of clauses. Each clause is a list of values of length $clause_size.
#The common case is clause_size 1 - but as we need to treat each clause as a list during validation - we need to list protect the clause when clause_size == 1.
if {$is_multiple} {
if {$clause_size == 1} {
foreach c $value_group {
lappend vlist [list $c]
}
} else {
set vlist $value_group
}
} else {
if {$clause_size ==1} {
set vlist [list [list $value_group]]
} else {
set vlist [list $value_group]
}
}
set vlist_typelist [list]
if {[dict exists $argument_clause_typestate $argname]} {
#lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-<tp>? or ?defaulted-<tp>? or ?validated-<tp>?.
# args.test: parse_withdef_value_clause_missing_optional_multiple
set vlist_typelist [dict get $argument_clause_typestate $argname]
} else {
foreach v $vlist {
lappend vlist_typelist $typelist
}
}
set vlist_original $vlist ;#retain for possible final strip_ansi
#review - validationtransform
if {[llength $vlist] && $is_validate_ansistripped} {
#validate_ansistripped 1
package require punk::ansi
set vlist_check [list]
foreach clause_value $vlist {
#lappend vlist_check [punk::ansi::ansistrip $clause_value]
set stripped [list]
foreach element $clause_value {
lappend stripped [punk::ansi::ansistrip $element]
}
lappend vlist_check $stripped
}
} else {
#validate_ansistripped 0
set vlist_check $vlist
}
switch -- [Dict_getdef $thisarg -ARGTYPE unknown] {
leader {
set dname leaders_dict
set argclass "Leading argument"
}
option {
set dname opts
set argclass Option
}
value {
set dname values_dict
set argclass "Trailing argument"
}
default {
set dname "_unknown_" ;#NA
set argclass "Unknown argument"
}
}
set vlist_validate [list]
set vlist_check_validate [list]
set vlist_typelist_validate [list]
#reduce our validation requirements by removing values which match defaultval or match -choices
#(could be -multiple with -choicerestricted 0 where some selections match and others don't)
if {$has_choices && $parsekey in $receivednames} {
#-choices must also work with -multiple
#todo -choicelabels
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}]
set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}]
#-choicealiases (G-040): alias -> canonical choice. Accepted exact (any -choiceprefix
#setting) and as prefix-calculation members when -choiceprefix is true; matched aliases
#normalize to their canonical choice in the parse result (see choiceword_match).
set choicealiases [Dict_getdef $thisarg -choicealiases {}]
set choicerestricted [tcl::dict::get $thisarg -choicerestricted]
set choicemultiple [tcl::dict::get $thisarg -choicemultiple]
if {[string is integer -strict $choicemultiple]} {
set choicemultiple [list $choicemultiple $choicemultiple]
}
lassign $choicemultiple choicemultiple_min choicemultiple_max
set nocase [tcl::dict::get $thisarg -nocase]
set choices [Dict_getdef $thisarg -choices {}]
set choicegroups [Dict_getdef $thisarg -choicegroups {}]
set allchoices $choices
if {[dict size $choicegroups]} {
dict for {groupname groupmembers} $choicegroups {
lappend allchoices {*}$groupmembers
}
}
#note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups
#This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes
set clause_index -1 ;#
#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)
#J2
#set vlist_validate [list]
#set vlist_check_validate [list]
foreach clause $vlist clause_check $vlist_check clause_typelist $vlist_typelist {
incr clause_index
set element_index -1 ;#element within clause - usually clause size is only 1
foreach e $clause e_check $clause_check {
incr element_index
set allchoices_in_list 0
if {$choicemultiple_max > 1 || $choicemultiple_max == -1} {
#vlist and vlist_check can be list of lists if -multiple and -choicemultiple
#each e represents 0 or more choice selections
set c_list $e
set c_check_list $e_check
#todo? check if entire list matches default?
} else {
#only one choice at a time - ensure single entry in c_list c_check_list
set c_list [list $e]
set c_check_list [list $e_check]
}
#-----------------------------------
#fast fail on the wrong number of choices
if {[llength $c_list] < $choicemultiple_min} {
set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg
#return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg
}
if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} {
set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices."
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $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 choices_test $allchoices
set v_test $c_check
}
set choice_in_list 0
set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval could be a list when -choicemultiple?
if {!$matches_default} {
#G-040: choice-word matching delegated to the shared resolver
#(punk::args::choiceword_match - also consumed by the punk::ns doc-lookup
# walk, so 'i <cmd> <word>' resolution cannot diverge from parsing)
set matchinfo [choiceword_match $c_check $nocase $allchoices $choicealiases $choiceprefix $choiceprefixdenylist $choiceprefixreservelist]
set choice_in_list [tcl::dict::get $matchinfo matched]
set choice_exact_match [tcl::dict::get $matchinfo exact]
set chosen [tcl::dict::get $matchinfo canonical]
#override the optimistic existing val (prefix-normalized or alias-normalized matches)
#our existing values in $dname are not list-protected - so we need to check clause_size
if {$choice_in_list && !$choice_exact_match} {
set existing [tcl::dict::get [set $dname] $argname_or_ident]
if {$choicemultiple_max != -1 && $choicemultiple_max < 2} {
#single choice allowed per clause-member
if {$is_multiple} {
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
#lset existing $element_index $chosen ;#wrong - test::punk::args test: choice_multiple_with_choiceprefix.
lset existing $clause_index $chosen
} else {
lset existing $clause_index $element_index $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
if {$clause_size == 1} {
#single-element clause - value in $dname is the plain (non list-wrapped) string.
#overwrite wholesale: lset would treat the scalar as a list and list-quote
#values needing quoting (backslashes/spaces) e.g {\Deleted}, giving a different
#value shape than exact input (G-046 item 3)
tcl::dict::set $dname $argname_or_ident $chosen
} else {
#test: choice_multielement_clause
lset existing $element_index $chosen
tcl::dict::set $dname $argname_or_ident $existing
}
}
} else {
if {$is_multiple} {
#puts ">>> existing $existing $choice_idx"
if {$clause_size == 1} {
#no list wrapping of single element in $dname dict - so don't index into it with element_index
lset existing $clause_index $choice_idx $chosen
} else {
lset existing $clause_index $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
} else {
#test required.
# punk::args::parse {{read write w}} withdef @values {mode -type list -choices {read write} -choicemultiple {1 -1}}
#puts ">>> clause_size $clause_size"
#puts ">>> existing $existing"
#puts ">>> lset existing $element_index $choice_idx $chosen"
if {$clause_size == 1} {
#e.g -type list
#we have multiple choices allowed for a single element clause because that clause type is a list.
lset existing $choice_idx $chosen
} else {
#e.g -type {any any}
lset existing $element_index $choice_idx $chosen
}
tcl::dict::set $dname $argname_or_ident $existing
}
}
}
}
if {!$choice_in_list && !$matches_default} {
if {!$choicerestricted} {
#if {$is_multiple} {
# set existing [tcl::dict::get [set $dname] $argname]
# lset existing $clause_index $v_test
# tcl::dict::set $dname $argname $existing
#} else {
# tcl::dict::set $dname $argname $v_test
#}
#JJJ
#lappend vlist_validate $c
#lappend vlist_check_validate $c_check
} else {
#unhappy path
#if prefixes allowed, first see if c_check is an ambiguous prefix
#This is preferable to listing all (possibly many) choices in the error message.
if {$choiceprefix} {
set prefixmsg " (or a unique prefix of a value)"
#review - case
if {$nocase} {
set longermatches [lsearch -all -inline -nocase $allchoices "$c_check*"]
} else {
set longermatches [lsearch -all -inline $allchoices "$c_check*"]
}
if {[llength $longermatches]} {
set msg "$argclass '$argname' for %caller% seems to be an ambiguous prefix. Try one of:\n [join $longermatches "\n "]\n$casemsg$prefixmsg. Received: '$c_check'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg
}
} else {
set prefixmsg ""
}
#review: $c vs $c_check for -badval?
set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg
#arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname
}
} else {
#choice is in list or matches default - no validation for this specific element in the clause
lset clause_typelist $element_index any
}
incr choice_idx
}
} ;#end foreach e in clause
#jjj 2025-07-16
#if not all clause_typelist are 'any'
if {[lsearch -not $clause_typelist any] > -1} {
#at least one element still needs validation
lappend vlist_validate $clause
lappend vlist_check_validate $clause_check
lappend vlist_typelist_validate $clause_typelist
}
} ;#end foreach clause in vlist
#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
set vlist_typelist $vlist_typelist_validate
}
#todo - don't add to validation lists if not in receivednames
#if we have an optionset such as "-f|-x|-etc"; the parsekey is -etc (unless it was overridden by -parsekey in definition)
if {$parsekey ni $receivednames} {
set vlist [list]
set vlist_check_validate [list]
} else {
if {$has_default && [llength $vlist]} {
#defaultval here is a value for the entire clause. (clause usually length 1)
#J2
#set vlist_validate [list]
#set vlist_check_validate [list]
#set tp [dict get $thisarg -type]
set clause_size [llength $typelist]
foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist {
#JJJJ
#REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation?
if {$clause_value ni $vlist_validate} {
if {$clause_size ==1} {
#for -choicemultiple with default that could be a list use 'ni'
#?? review!
if {[lindex $clause_check 0] ne $defaultval} {
lappend vlist_validate $clause_value
lappend vlist_check_validate $clause_check
lappend vlist_typelist_validate $clause_typelist
}
} else {
if {$clause_check ne $defaultval} {
lappend vlist_validate $clause_value
lappend vlist_check_validate $clause_check
lappend vlist_typelist_validate $clause_typelist
}
}
}
#if {[llength $tp] == 1} {
# if {$clause_value ni $vlist_validate} {
# #for -choicemultiple with default that could be a list use 'ni'
# #?? review!
# if {[lindex $clause_check 0] ne $defaultval} {
# lappend vlist_validate $clause_value
# lappend vlist_check_validate $clause_check
# }
# }
#} else {
# if {$clause_value ni $vlist_validate} {
# if {$clause_check ne $defaultval} {
# lappend vlist_validate $clause_value
# lappend vlist_check_validate $clause_check
# }
# }
#}
#Todo?
#else ???
}
set vlist $vlist_validate
set vlist_check $vlist_check_validate
set vlist_typelist $vlist_typelist_validate
}
}
if {[llength $vlist]} {
#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 {!$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
}
}
}
}
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
#$t = clause column
#for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {}
set clausecolumn -1
foreach typespec $typelist {
incr clausecolumn
if {[dict exists $thisarg -typedefaults]} {
set tds [dict get $thisarg -typedefaults]
if {[lindex $vlist $clausecolumn] eq [lindex $tds $clausecolumn]} {
continue
}
}
set type_expression [string trim $typespec ?]
if {$type_expression in {any none unknown}} {
continue
}
#puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]"
#set typespec [lindex $typelist $clausecolumn]
#todo - handle type-alternates e.g -type char|double
#------------------------------------------------------------------------------------
#private::check_clausecolumn argname argclass thisarg thisarg_checks column default_type_expression list_of_clauses list_of_clauses_check list_of_clauses_typelist
check_clausecolumn $argname $argclass $thisarg $thisarg_checks $clausecolumn $type_expression $vlist $vlist_check $vlist_typelist $argspecs
#------------------------------------------------------------------------------------
#todo - pass validation if matches an entry in -typedefaults
#has_typedefault?
#set typedefault [lindex $typedefaults $clausecolumn]
}
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 {$is_multiple} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
}
}
}
}
}
}
set finalopts [dict create]
dict for {o v} $opts {
if {[string first | $o] > -1} {
#set parsekey [lindex [split $o |] end]
dict set finalopts [lindex [split $o |] end] $v
} else {
dict set finalopts $o $v
}
}
set docid [dict get $argspecs id]
#G-041: form records the parsed form (auto-selected for multiform definitions).
#Positional consumers (lassign [dict values ...]) rely on the first keys - new
#keys are appended after id.
return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived id $docid form $fid]
}
lappend PUNKARGS [list {
@id -id ::punk::args::forms
@cmd -name punk::args::forms\
-summary\
"List command forms."\
-help\
"Return names for each form of a command identified by 'id'.
Most commands are single-form and will only return the name '_default'."
@leaders -min 0 -max 0
@opts
@values -min 1 -max 1
id -multiple 0 -optional 0 -help\
"Exact id of command"
}]
proc forms {id} {
set spec [get_spec $id]
if {[dict size $spec]} {
return [dict get $spec form_names]
} else {
return [list]
}
}
lappend PUNKARGS [list {
@id -id ::punk::args::eg
@cmd -name punk::args::eg\
-summary\
"Command examples."\
-help\
"Return command examples from -help in @examples
directive of a command definition."
@values -min 1 -max -1
cmditem -multiple 1 -optional 0
}]
proc eg {args} {
set argd [punk::args::parse $args withid ::punk::args::eg]
lassign [dict values $argd] leaders opts values received
set cmditems [dict get $values cmditem]
set id [lindex $cmditems 0]
set cmdargs [lrange $cmditems 1 end]
set spec [get_spec $id]
if {$spec eq ""} {
return
}
set spec [private::expand_display_fields $spec] ;#G-046 @examples -help may be deferred
if {[dict exists $spec examples_info -help]} {
set egdata [dict get $spec examples_info -help]
return [punk::args::helpers::strip_nodisplay_lines $egdata]
} else {
return "no @examples defined for $id"
}
}
proc private::synopsis_choice_literals {arginfo} {
#Small restricted choice sets display in synopses as unitalicised literal alternates,
#matching the display style of literal()/literalprefix() type-alternatives.
#Returns a list of list-protected choice words, or an empty list when the rule doesn't apply:
# - more than 3 choices (reader should refer to the full help for the choice list)
# - -choicerestricted 0 (other values are also acceptable - bare literals would be misleading)
#A defined -typesynopsis always takes precedence - callers consult it before this.
set allchoices [list]
if {[dict exists $arginfo -choices]} {
set allchoices [dict get $arginfo -choices]
}
foreach {groupname members} [Dict_getdef $arginfo -choicegroups {}] {
lappend allchoices {*}$members
}
set allchoices [punk::args::lib::lunique $allchoices]
if {[llength $allchoices] == 0 || [llength $allchoices] > 3} {
return [list]
}
if {![Dict_getdef $arginfo -choicerestricted 1]} {
return [list]
}
set literals [list]
foreach c $allchoices {
lappend literals [list $c]
}
return $literals
}
proc private::synopsis_form_arg_display {formdict argname} {
#non-colour SGR such as bold/italic/strike - so we don't need to worry about NOCOLOR settings
set I "\x1b\[3m" ;#[punk::ansi::a+ italic]
set NI "\x1b\[23m" ;# [punk::ansi::a+ noitalic]
#for inner question marks marking optional type
set IS "\x1b\[3\;9m" ;#[punk::ansi::a+ italic strike]
set NIS "\x1b\[23\;29m" ;#[punk::ansi::a+ noitalic nostrike]
set RST "\x1b\[m" ;#[punk::ansi::a]
set arginfo [dict get $formdict ARG_INFO $argname]
set typelist [dict get $arginfo -type]
set ts [Dict_getdef $arginfo -typesynopsis ""]
set n [expr {[llength $typelist]-1}]
if {![catch {llength $argname}]} {
set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types
} else {
#argname is not a valid Tcl list - so we can't take tail words from it for display hints
set name_tail [list $argname]
}
set clause ""
if {$ts ne ""} {
set tp_displaylist $ts
} else {
set tp_displaylist [lrepeat [llength $typelist] ""]
}
if {[llength $typelist] == 1} {
set choice_literals [private::synopsis_choice_literals $arginfo]
} else {
#choice semantics for multi-element clauses are per-clause - keep name/type display hints
set choice_literals [list]
}
foreach typespec $typelist td $tp_displaylist elementname $name_tail {
#elementname will commonly be empty after first iteration
if {[string match {\?*\?} $typespec]} {
set tp [string range $typespec 1 end-1]
set member_optional 1
} else {
set tp $typespec
set member_optional 0
}
if {$td ne ""} {
set c $td
} else {
#handle alternate-types e.g literal(text)|literal(binary)
set alternates [list]
set type_alternatives [private::split_type_expression $tp]
foreach tp_alternative $type_alternatives {
set tp_alternative_word1 [lindex $tp_alternative 0]
set match [lindex $tp_alternative 1]
switch -exact -- $tp_alternative_word1 {
literal {
lappend alternates [list $match]
}
literalprefix {
#todo - trie styling on prefix calc
lappend alternates [list $match]
}
stringstartswith {
lappend alternates [list $match*]
}
stringendswith {
lappend alternates [list *$match]
}
default {
#we'll only take display hints from the name itself if there was no defined typesynopsis element for this position in the type,
#and if the type-alternatives don't specify a literal or string match that we can use for display
#and if there are enough tail words in the argname to match the position in the type list
#empty strings can be put in -typesynopsis positions to only override the type information for certain elements of the clause
#- e.g for a type list of {string int} we could specify a typesynopsis of {"" "count"} to get display of "FILENAME count" for an argname of "file FILENAME FILECOUNT"
if {[llength $choice_literals]} {
lappend alternates {*}$choice_literals
} elseif {[llength $name_tail] >= [llength $typelist]} {
#important to list protect $elementname e.g look at ::apply
#The name may contain spaces e.g "{args body ?namespace?}"
#This must not be split into multiple words - it is a single element name that happens to contain spaces.
lappend alternates $I[list $elementname]$NI
} else {
lappend alternates $I<$tp_alternative>$NI
}
}
}
}
set alternates [punk::args::lib::lunique $alternates]
set c [join $alternates |]
}
if {$member_optional} {
#append clause " " "(?$c?)"
append clause " " "\[$c\]"
} else {
append clause " " $c
}
}
set clause [string trimleft $clause]
#set ARGD [dict create argname $argname class leader]
if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} {
if {[dict get $arginfo -multiple]} {
#set display "?$I$argname$NI?..."
set display "\[$clause\]..."
} else {
set display "\[$clause\]"
}
} else {
if {[dict get $arginfo -multiple]} {
#set display "$I$argname$NI ?$I$argname$NI?..."
set display "$clause \[$clause\]..."
} else {
set display $clause
}
}
return $display
}
lappend PUNKARGS [list {
@id -id ::punk::args::synopsis
@cmd -name punk::args::synopsis\
-summary\
"Command synopsis"\
-help\
"Return synopsis for each form of a command
on separate lines.
If -form <formname> is given, supply only
the synopsis for that form.
"
@opts
-noheader -type none
-form -type string -default *
-return -type string -default full -choices {full summary dict}
@values -min 1 -max -1
cmditem -multiple 1 -optional 0
}]
proc synopsis {args} {
#synopsis potentially called repeatedly with same args? use -cache 1
set argd [punk::args::parse $args -cache 1 withid ::punk::args::synopsis]
#non-colour SGR such as bold/italic/strike - so we don't need to worry about NOCOLOR settings
set I "\x1b\[3m" ;#[punk::ansi::a+ italic]
set NI "\x1b\[23m" ;# [punk::ansi::a+ noitalic]
#for inner question marks marking optional type
set IS "\x1b\[3\;9m" ;#[punk::ansi::a+ italic strike]
set NIS "\x1b\[23\;29m" ;#[punk::ansi::a+ noitalic nostrike]
set RST "\x1b\[m" ;#[punk::ansi::a]
##set form *
##if {[lindex $args 0] eq "-form"} {
## set arglist [lrange $args 2 end]
## set form [lindex $args 1]
##} else {
## set arglist $args
##}
##if {[llength $arglist] == 0} {
## error "punk::args::synopsis expected command id possibly with trailing subcommands/args"
##}
##set id [lindex $arglist 0]
##set cmdargs [lrange $arglist 1 end]
lassign [dict values $argd] leaders opts values received
set form [dict get $opts -form]
set opt_return [dict get $opts -return]
set cmditems [dict get $values cmditem]
set cmdargs [lassign $cmditems id]
set spec [get_spec $id]
if {$spec eq ""} {
return
}
set dict_idx_to_name [dict create]
set dict_name_to_idx [dict create]
set all_form_names [dict get $spec form_names]
set idx 0
#assert: form_names is ordered as defined in the command definition - so idx into it is stable.
foreach fn $all_form_names {
dict set dict_idx_to_name $idx $fn
dict set dict_name_to_idx $fn $idx
incr idx
}
set form_names $all_form_names
if {$form ne "*"} {
if {[string is integer -strict $form]} {
set f [lindex $form_names $form]
if {$f ne ""} {
set form_names [list $f]
} else {
set form_names [list]
}
} else {
set fmatch [tcl::prefix::match -error "" $all_form_names $form]
if {$fmatch ne ""} {
set form_names [list $fmatch]
} else {
set form_names [list]
}
}
}
set SYND [dict create]
set c_info [dict get $spec cmd_info]
set cmd_info [dict create]
dict for {k v} $c_info {
if {[string match -* $k]} {
dict set cmd_info [string range $k 1 end] $v
}
}
dict set SYND COMMAND $cmd_info
#leading "# " required (punk::ns::synopsis will pass through)
if {![dict exists $received -noheader]} {
set syn "# [Dict_getdef $spec cmd_info -summary ""]\n"
set GRY "\x1b\[38\;5\;8m"
set RST "\x1b\[m"
}
#todo - -multiple etc
foreach f $form_names {
set forminfo [dict get $spec FORMS $f]
set idx [dict get $dict_name_to_idx $f]
dict set SYND FORMS $f [dict create]
if {![dict exists $received -noheader]} {
set formsummary "FORM $idx $f"
if {[dict exists $forminfo -summary]} {
append formsummary " - [dict get $forminfo -summary]"
}
append syn "## $GRY$formsummary$RST\n"
}
append syn "$id"
set FORMARGS [list]
foreach argname [dict get $forminfo LEADER_NAMES] {
set display [private::synopsis_form_arg_display $forminfo $argname]
append syn " $display"
set arginfo [dict get $forminfo ARG_INFO $argname]
set ARGD [dict create argname $argname class leader]
dict set ARGD type [dict get $arginfo -type]
dict set ARGD optional [dict get $arginfo -optional]
dict set ARGD multiple [dict get $arginfo -multiple]
foreach k {choices choiceprefix choicerestricted choicemultiple} {
if {[dict exists $arginfo -$k]} {
dict set ARGD $k [dict get $arginfo -$k]
}
}
dict set ARGD display $display
lappend FORMARGS $ARGD
}
foreach argname [dict get $forminfo OPT_NAMES] {
set arginfo [dict get $forminfo ARG_INFO $argname]
set ARGD [dict create argname $argname class option]
set tp [dict get $arginfo -type]
if {$tp eq "none"} {
#assert - argname may have aliases delimited by | - but no aliases end with =
#(disallowed in punk::args::define)
set argdisplay $argname
} else {
#assert [llength $tp] == 1 (multiple values for flag unsupported in punk::args::define)
if {[string match {\?*\?} $tp]} {
set tp [string range $tp 1 end-1]
set value_is_optional true
} else {
set value_is_optional false
}
set ts [Dict_getdef $arginfo -typesynopsis ""]
if {$ts ne ""} {
set tp_display $ts
#user may or may not have remembered to match the typesynopsis with the optionality by wrapping with ?
#review - if user wrapped with ?*? and also leading/trailing ANSI - we won't properly strip
#todo - enforce no wrapping '?*?' in define for -typesynopsis?
set tp_display [string trim $tp_display ?]
} else {
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
set choice_literals [private::synopsis_choice_literals $arginfo]
set type_alternatives [private::split_type_expression $tp]
foreach tp_alternative $type_alternatives {
set match [lindex $tp_alternative 1]
switch -- [lindex $tp_alternative 0] {
literal {
lappend alternates [list $match]
}
literalprefix {
lappend alternates [list $match]
}
stringstartswith {
lappend alternates [list $match*]
}
stringendswith {
lappend alternates [list *$match]
}
default {
if {[llength $choice_literals]} {
lappend alternates {*}$choice_literals
} else {
lappend alternates $I<$tp_alternative>$NI
}
}
}
}
#trie prefixes display?
#we probably don't want to show prefixes in synopsis.
#AI agents should be encouraged to use full values for clarity, and human users can refer to help for the prefix info if they care.
set alternates [punk::args::lib::lunique $alternates]
set tp_display [join $alternates |]
}
if {[string first | $tp_display] >=0} {
#need to bracket alternate-types to distinguish pipes delimiting flag aliases
set tp_display "($tp_display)"
}
#consider optional: -f|--file|--file= -type string|num
#we can't show this as [-f|--file|--file= string|num]
#because the pipes make visually parsing it ambiguous.
#we *could* show this as [-f|--file|--file= (string|num)]
# but it lacks clarity in descripting we can supply --file string or --file=string
#showing it as [-f (string|num)|--file (string|num)|--file=(string|num)] is not as compact as it could be, but is reasonably precise.
#we could merge the first two to avoid repeating the type info - but then we would also need brackets to clarify the pipe applicability:
#e.g
# [(-f|--file (string|num))|--file=(string|num)]
#
#we choose to only merge in the case where there are no trailing= aliases or they are all trailing= aliases.
set aliasflags [split $argname |]
#set has_longopt_inlinevalue_alias [expr {[lsearch -glob $aliasflags *=] >= 0}]
set num_longopt_inlinevalue_aliases [llength [lsearch -all -glob $aliasflags *=]] ;#count list of indices of aliasflags that end with =
set homogenous_aliases [expr {$num_longopt_inlinevalue_aliases == 0 || $num_longopt_inlinevalue_aliases == [llength $aliasflags]}]
set argdisplay ""
if {!$homogenous_aliases} {
foreach aliasflag $aliasflags {
if {[string match --* $aliasflag]} {
if {[string index $aliasflag end] eq "="} {
set alias [string range $aliasflag 0 end-1]
if {$value_is_optional} {
#append argdisplay "$alias$IS\[$NIS=$tp_display$IS\]$NIS|"
append argdisplay "$alias$I\[$NI=$tp_display$I\]$NI|"
} else {
append argdisplay "$alias=$tp_display|"
}
} else {
if {$value_is_optional} {
#double-dashed flag without trailing = can't accept optional value
#append argdisplay "$aliasflag $IS\[$NIS$tp_display$IS\]$NIS|"
append argdisplay "$aliasflag|"
} else {
append argdisplay "$aliasflag $tp_display|"
}
}
} else {
if {$value_is_optional} {
#flag can't accept optional value
append argdisplay "$aliasflag|"
} else {
append argdisplay "$aliasflag $tp_display|"
}
}
}
set argdisplay [string trimright $argdisplay |]
} else {
if {$num_longopt_inlinevalue_aliases > 0} {
#all aliases are longopt inlinevalue aliases
#review
# --file=|--fname= -type string
# -> (--file|--fname)=type
# or
# -> (--file|--fname)[=type]
#first transform the argname to remove the trailing = and bracket the aliases if there are multiple
#review - we don't expect any arguments to be defined with inner = in the name.
#todo - enforce no inner = in argname in punk::args::define for options?
#
set argname "[string map {= ""} $argname]"
if {$num_longopt_inlinevalue_aliases > 1} {
set argname "($argname)"
}
if {$value_is_optional} {
set argdisplay "$argname$I\[$NI=$tp_display$I\]$NI"
} else {
set argdisplay "$argname=$tp_display"
}
} else {
#no longopts with trailing = aliases, so we can show the type info without ambiguity as applying to all aliases
if {$value_is_optional} {
set argdisplay "$argname $I\[$NI$tp_display$I\]$NI"
} else {
set argdisplay "$argname $tp_display"
}
}
}
}
if {[dict get $arginfo -optional]} {
if {[dict get $arginfo -multiple]} {
#set display "?$argdisplay?..."
set display "\[$argdisplay\]..."
} else {
#set display "?$argdisplay?"
set display "\[$argdisplay\]"
}
} else {
if {[dict get $arginfo -multiple]} {
#set display "$argdisplay ?$argdisplay?..."
set display "$argdisplay \[$argdisplay\]..."
} else {
set display $argdisplay
}
}
#if {[string index $argname end] eq "="} {
# set __ ""
#} else {
# set __ " "
#}
#if {[dict get $arginfo -optional]} {
# if {[dict get $arginfo -multiple]} {
# if {$tp eq "none"} {
# set display "?$argname?..."
# } else {
# set display "?$argname$__$tp_display?..."
# }
# } else {
# if {$tp eq "none"} {
# set display "?$argname?"
# } else {
# set display "?$argname$__$tp_display?"
# }
# }
#} else {
# if {[dict get $arginfo -multiple]} {
# if {$tp eq "none"} {
# set display "$argname ?$argname...?"
# } else {
# set display "$argname$__$tp_display ?$argname$__$tp_display?..."
# }
# } else {
# if {$tp eq "none"} {
# set display $argname
# } else {
# set display "$argname$__$tp_display"
# }
# }
#}
#todo -mash
append syn " $display"
dict set ARGD type [dict get $arginfo -type]
dict set ARGD optional [dict get $arginfo -optional]
dict set ARGD multiple [dict get $arginfo -multiple]
foreach k {choices choiceprefix choicerestricted choicemultiple} {
if {[dict exists $arginfo -$k]} {
dict set ARGD $k [dict get $arginfo -$k]
}
}
dict set ARGD display $display
#dict lappend SYND $f $ARGD
lappend FORMARGS $ARGD
}
foreach argname [dict get $forminfo VAL_NAMES] {
set arginfo [dict get $forminfo ARG_INFO $argname]
set display [private::synopsis_form_arg_display $forminfo $argname]
append syn " $display"
set ARGD [dict create argname $argname class value]
dict set ARGD type [dict get $arginfo -type]
dict set ARGD optional [dict get $arginfo -optional]
dict set ARGD multiple [dict get $arginfo -multiple]
foreach k {choices choiceprefix choicerestricted choicemultiple} {
if {[dict exists $arginfo -$k]} {
dict set ARGD $k [dict get $arginfo -$k]
}
}
dict set ARGD display $display
lappend FORMARGS $ARGD
}
#accepts unnamed extra arguments e.g toplevel docid for ensembles and ensemble-like commands
if {[dict get $forminfo VAL_UNNAMED]} {
set display {[<unnamed>...]}
append syn " $display"
set ARGD [dict create argname "" class value]
dict set ARGD type any
dict set ARGD optional 1
dict set ARGD multiple 1
dict set ARGD display $display
lappend FORMARGS $ARGD
}
append syn \n
dict set SYND FORMS $f args $FORMARGS
}
switch -- $opt_return {
full {
return [string trim $syn \n]
}
summary {
set summary ""
if {![dict exists $received -noheader]} {
set summary "# [Dict_getdef $spec cmd_info -summary ""]\n"
}
set FORMS [dict get $SYND FORMS]
dict for {form arginfo} $FORMS {
set arglist [dict get $arginfo args]
append summary $id
set class_state leader
set option_count 0
set value_count 0
foreach ainfo $arglist {
switch -- [dict get $ainfo class] {
leader {
append summary " [dict get $ainfo display]"
}
option {
incr option_count
}
value {
incr value_count
if {$class_state ne "value"} {
if {$option_count > 0} {
append summary " \[OPTIONS ($option_count defined)\]"
}
set class_state value
}
append summary " [dict get $ainfo display]"
}
}
}
if {$value_count == 0 && $option_count > 0} {
append summary " \[OPTIONS ($option_count defined)\]"
}
append summary \n
}
set summary [string trim $summary \n]
#only return as summary if full synopsis is wider
#(e.g single option can commonly be shorter than "?options (1 defined)?"
if {[textblock::width $summary] < [textblock::width $syn]} {
return $summary
} else {
return [string trim $syn \n]
}
}
dict {
return $SYND
}
}
}
#REVIEW
lappend PUNKARGS [list {
@id -id ::punk::args::synopsis_summary
@cmd -name punk::args::synopsis_summary -help\
"Reduce the width of a synopsis string
by coalescing options to ?options?...
synopsis string may be arbitrarily marked
up with ANSI codes."
@opts
@values -min 1 -max -1
synopsis -multiple 0 -optional 0
}]
proc synopsis_summary {args} {
set argd [punk::args::parse $args -cache 1 withid ::punk::args::synopsis_summary]
set synopsis [dict get $argd values synopsis]
set summary ""
foreach sline [split $synopsis \n] {
set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review
set in_opt 0
set line_out ""
set codestack [list]
set parts [punk::ansi::ta::split_codes_single $sline]
#basic
foreach {pt code} $parts {
set charlist [split $pt ""]
for {set i 0} {$i < [llength $charlist]} {incr i} {
set c [lindex $charlist $i]
switch -- $c {
? {
if {!$in_opt} {
set in_opt 1
} else {
}
}
" " {
if {!$in_opt} {
append line_out " "
} else {
set in_opt
}
}
default {
if {!$in_opt} {
append line_out $c
}
}
}
}
if {$code ne "" && [tcl::string::index $code end] eq "m"} {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
#set codestack [list "\x1b\[m"]
set codestack [list $code]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#basic simplification first - remove straight dupes
set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
}
}
#? ignore other ANSI codes?
}
if {[string match -* $plain_s] || [string match ?- $plain_s]} {
}
}
return $summary
}
lappend PUNKARGS [list {
@id -id ::punk::args::ensemble_subcommands_definition
@cmd -name ::punk::args::ensemble_subcommands_definition -help\
"Helper function to return a punk::args definition snippet for ensemble subcommands"
@leaders -max 0 -min 0
-groupdict -default {} -type dict -help\
"Dictionary keyed on arbitrary groupname, where value
is a list of known subcommands that should be displayed
by groupname. Each groupname forms the title of a subtable
in the choices list.
Subcommands not assigned to a groupname will appear first
in an untitled subtable."
-columns -default 2 -type integer -help\
"Max number of columns for all subtables in the choices
display area"
@values -min 1 -max 1
ensemble -optional 0 -help\
"Name of ensemble command"
}]
proc ensemble_subcommands_definition {args} {
#args manually parsed - with use of argdef for unhappy-path only
if {![llength $args]} {
punk::args::parse $args -errorstyle minimal withid ::punk::args::ensemble_subcommands_definition
return
}
set ensemble [lindex $args end]
set optlist [lrange $args 0 end-1]
if {[llength $optlist] % 2} {
punk::args::parse $args -errorstyle minimal withid ::punk::args::ensemble_subcommands_definition
return
}
set defaults [dict create {*}{
-groupdict {}
-columns 2
}]
set optlist [dict merge $defaults $optlist]
dict for {k v} $optlist {
switch -- $k {
-groupdict - -columns {}
default {
punk::args::parse $args -errorstyle minimal withid ::punk::args::ensemble_subcommands_definition
return
}
}
}
set opt_groupdict [dict get $optlist -groupdict]
set opt_columns [dict get $optlist -columns]
#warning - circular package dependency if we try to use this function on punk::ns!
package require punk::ns
set subdict [uplevel 1 [list punk::ns::ensemble_subcommands -return dict $ensemble]]
set unkhandler [uplevel 1 [list ::tcl::namespace::ensemble configure $ensemble -unknown]]
# ----------------------------------------------------------------------------------------------------------------------------
#resolution for unknown if performed via another ensemble (eg see punk::lib::ensemble::extend and "ensemble extend" on wiki)
#we cannot sensibly determine subcommands for arbitrary -unknown scripts - but we can for this known (common?) method
# Note that an ensemble might have been extended this way more than once.
set resolve_unknowns 1
set next_handler $unkhandler
while {$resolve_unknowns} {
#ensure bogus isn't in already known subcommands
set n 1
set bogus "<bogussubcommand$n>"
set known_subs [dict keys $subdict]
while {$bogus in $known_subs} {
incr n
set bogus "<bogussubcommand$n>"
}
if {![catch {uplevel 1 [list {*}$next_handler] $ensemble $bogus} unk_resolver]} {
lassign $unk_resolver unk_ensemble
if {[uplevel 1 [list ::tcl::namespace::ensemble exists $unk_ensemble]]} {
set unkdict [uplevel 1 [list punk::ns::ensemble_subcommands -return dict $unk_ensemble]]
set subdict [dict merge $unkdict $subdict]
set next_handler [uplevel 1 [list ::tcl::namespace::ensemble configure $unk_ensemble -unknown]]
if {$next_handler eq ""} {
set resolve_unknowns 0
}
} else {
set resolve_unknowns 0
}
} else {
set resolve_unknowns 0
}
}
# ----------------------------------------------------------------------------------------------------------------------------
set allsubs [dict keys $subdict]
# ----------------------------------------------
# manually defined group members may have subcommands that are obsoleted/missing
# we choose to make the situation obvious by re-classifying into a corresponding group with the " - MISSING" suffix
set checked_groupdict [dict create]
dict for {g members} $opt_groupdict {
set validmembers {}
set invalidmembers {}
foreach m $members {
if {$m in $allsubs} {
lappend validmembers $m
} else {
lappend invalidmembers $m
}
}
dict set checked_groupdict $g $validmembers
if {[llength $invalidmembers]} {
dict set checked_groupdict "${g}_MISSING" $invalidmembers
}
}
if {[dict exists $checked_groupdict ""]} {
set others [dict get $checked_groupdict ""]
dict unset checked_groupdict ""
} else {
set others [list]
}
#REVIEW
set debug 0
if {$debug} {
puts "punk::args::ensemble_subcommands_definition"
if {[catch {
::punk::lib::pdict checked_groupdict
} msg]} {
puts stderr "punk::args::ensemble_subcommands_definition Cannot call pdict\n$msg"
}
puts --------------------
puts "$checked_groupdict"
puts --------------------
}
set opt_groupdict $checked_groupdict
# ----------------------------------------------
set allgrouped [list]
dict for {g members} $opt_groupdict {
lappend allgrouped {*}$members
}
set choiceinfodict [dict create]
set choicelabelsdict [dict create]
foreach {sc cmd} $subdict {
if {$sc ni $allgrouped} {
if {$sc ni $others} {
lappend others $sc
}
}
#sometimes the subdict we get from the namespace ensemble map is not sorted
set others [lsort $others]
#don't use full cmdinfo if $cmd is a single element
if {[llength $cmd] == 1} {
set cinfo [punk::ns::cmdwhich $cmd]
set tp [dict get $cinfo whichtype]
} else {
puts stderr "WARNING ==ensemble_subcommands_definition== cmdinfo $cmd\n$cinfo"
set cinfo [punk::ns::cmdinfo {*}$cmd]
set tp [dict get $cinfo cmdtype]
}
#-resolved-
dict set choiceinfodict $sc [list [list ensemblesubtarget {*}$cmd]]
switch -- $tp {
ensemble - native {
dict lappend choiceinfodict $sc [list doctype $tp]
}
object {
dict lappend choiceinfodict $sc [list doctype oo]
}
}
#could be more than one punk::args id - choose a precedence by how we order the id_exists checks.
set id_checks [list {*}{
} "$ensemble $sc" {*}{
} $cmd {*}{
} [dict get $cinfo origin] {*}{
}
]
#id_exists only sees definitions already loaded - registered argdocs
#(::punk::args::register::NAMESPACES) load lazily, and callers such as the
#punk::ns doc-lookup path only load the ensemble command's parent namespace.
#Load the namespaces the id_checks could resolve in, or a first call before
#they are loaded (e.g 'i <ensemble>' in a fresh shell) builds the definition
#without subhelp/choicelabel entries for documented subcommands.
set id_check_namespaces [list]
foreach checkid $id_checks {
set idns [namespace qualifiers $checkid]
if {$idns eq ""} {set idns ::}
if {$idns ni $id_check_namespaces} {lappend id_check_namespaces $idns}
}
punk::args::update_definitions $id_check_namespaces
set N [punk::ansi::a+ normal]
set RST [punk::ansi::a]
foreach checkid $id_checks {
if {[punk::args::id_exists $checkid]} {
dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}$checkid]
#dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::ns::synopsis $checkid][punk::ansi::a]
#dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::args::synopsis $checkid][punk::ansi::a]
dict set choicelabelsdict $sc ${N}[punk::args::synopsis -return summary $checkid]${RST}
break
}
}
#if {[punk::args::id_exists [list $ensemble $sc]]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
# dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc]
#} elseif {[punk::args::id_exists $cmd]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
# dict lappend choiceinfodict $sc [list subhelp {*}$cmd]
#} elseif {[punk::args::id_exists [dict get $cinfo origin]]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
# dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]]
#}
#foreach id [punk::args::get_ids "::package *"] {
# if {[llength $id] == 2} {
# lassign $id _ sub
# dict set PACKAGE_CHOICEINFO $sub {{doctype native} {doctype punkargs}}
# #override manual synopsis entry
# dict set PACKAGE_CHOICELABELS $sub [punk::ns::synopsis "::package $sub"]
# }
#}
#if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
#}
}
set help ""
if {$unkhandler ne ""} {
set help [list -help "[punk::ansi::a+ bold]WARNING: -unknown handler exists. Not all options may be displayed.[punk::ansi::a]"]
}
set argdef ""
append argdef "subcommand $help -choicegroups \{" \n
append argdef " \"\" \{$others\}" \n
dict for {g members} $opt_groupdict {
append argdef " \"$g\" \{$members\}" \n
}
append argdef " \} -choicecolumns $opt_columns -choicelabels \{" \n
append argdef " $choicelabelsdict" \n
append argdef " \} -choiceinfo \{$choiceinfodict\} -unindentedfields \{-choicelabels\}" \n
#todo -choicelabels
#detect subcommand further info available e.g if oo or ensemble or punk::args id exists..
#consider a different mechanism to add a label on rhs of same line as choice (for (i) marker)
return $argdef
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::args ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::args::lib {
variable PUNKARGS
tcl::namespace::export {[a-z]*}
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]
#tcl86 compat for string is dict - but without -strict or -failindex options
lappend PUNKARGS [list {
@id -id ::punk::args::lib::string_is_dict
@cmd -name punk::args::lib::string_is_dict\
-summary\
"Test whether a string is a valid dict ('string is dict' compatibility wrapper)."\
-help\
"Returns a boolean indicating whether the string can be interpreted
as a dictionary (an even-length list).
On Tcl 9+ this is a thin wrapper over 'string is dict'.
On earlier Tcl versions a compatible fallback is used which accepts
but ignores any leading options (-strict/-failindex are NOT implemented)."
@values -min 1 -max -1
arg -type any -multiple 1 -help\
"optional 'string is dict' options followed by the string to test.
Only the final argument (the string) is significant on pre-9 Tcl."
}]
if {[catch {string is dict {}} errM]} {
proc string_is_dict {args} {
#compatibility for tcl pre 9.0
#ignores opts
set str [lindex $args end]
if {[catch {llength $str} len]} {
return 0
}
if {$len % 2 == 0} {
return 1
}
return 0
}
} else {
proc string_is_dict {args} {
#tcl 9+ version
string is dict {*}$args
}
}
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {option value...}]]
# #[para]Description of utility1
# return 1
#}
lappend PUNKARGS [list {
@id -id ::punk::args::lib::flatzip
@cmd -name punk::args::lib::flatzip\
-summary\
"Interleave two lists into a single flat list."\
-help\
"Returns a flat list alternating elements from l1 and l2.
e.g flatzip {a b c} {1 2 3} -> a 1 b 2 c 3"
@values -min 2 -max 2
l1 -type list -help\
"first list"
l2 -type list -help\
"second list"
}]
proc flatzip {l1 l2} {
concat {*}[lmap a $l1 b $l2 {list $a $b}]
}
lappend PUNKARGS [list {
@id -id ::punk::args::lib::zero_based_posns
@cmd -name punk::args::lib::zero_based_posns\
-summary\
"Return the list of zero-based positions 0..count-1."\
-help\
"Returns a list of integers from 0 to count-1,
or an empty result if count < 1.
Uses lseq where available (Tcl 8.7+) for efficiency."
@values -min 1 -max 1
count -type integer -help\
"number of positions"
}]
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}
#expr wrapper required: lseq in Tcl 9.1+ (TIP 746) no longer evaluates expression operands
lseq 0 [expr {$count-1}]
}
} else {
proc zero_based_posns {count} {
if {$count < 1} {return}
lsearch -all [lrepeat $count 0] *
}
}
#return list of single column-width marks - possibly with ansi
lappend PUNKARGS [list {
@id -id ::punk::args::lib::choiceinfo_marks
@cmd -name punk::args::lib::choiceinfo_marks\
-summary\
"Return display marks for a choice based on its -choiceinfo entries."\
-help\
"Returns a list of single column-width marks (possibly containing ANSI)
indicating documentation types (punkargs/ensemble/oo/native etc.)
recorded for the choice in a -choiceinfo dictionary.
Used when rendering choice tables in usage output."
@values -min 2 -max 2
choice -type string -help\
"choice name to look up"
choiceinfodict -type dict -help\
"-choiceinfo dictionary from an argument definition"
}]
proc choiceinfo_marks {choice choiceinfodict} {
set marks [list]
if {[dict exists $choiceinfodict $choice]} {
set cinfo [dict get $choiceinfodict $choice]
foreach info $cinfo {
if {[lindex $info 0] eq "doctype"} {
switch -- [lindex $info 1] {
punkargs {
lappend marks [punk::ns::Cmark punkargs brightgreen]
}
ensemble {
lappend marks [punk::ns::Cmark ensemble brightyellow]
}
oo {
lappend marks [punk::ns::Cmark oo brightcyan]
}
ooc {
lappend marks [punk::ns::Cmark ooc cyan]
}
classmethod {
lappend marks [punk::ns::Cmark classmethod term-orange1]
}
coremethod {
lappend marks [punk::ns::Cmark coremethod term-plum1]
}
ooo {
lappend marks [punk::ns::Cmark ooo cyan]
}
objectmethod {
lappend marks [punk::ns::Cmark objectmethod term-orange1]
}
native {
lappend marks [punk::ns::Cmark native]
}
unknown {
lappend marks [punk::ns::Cmark unknown brightred]
}
}
}
}
}
return $marks
}
#experiment with equiv of js template literals with ${expression} in templates
#e.g tstr {This is the value of x in calling scope ${$x} !}
#e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !}
#e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !}
lappend PUNKARGS [list {
@id -id ::punk::args::lib::tstr
@cmd -name punk::args::lib::tstr\
-summary\
"Templating with placeholders such as: \$\{$varName\}"\
-help\
"Roughly analogous to js template literals
Placeholder Substitutions:
\$\{$varName\}
\$\{[myCommand]\}
(myCommand is evaluated when -allowcommands flag is given)
If any error occurs during placeholder evaluation, the original placeholder text
is substituted in the output and the error is included in the returned dict
(if -return dict is used).
"
-allowcommands -default 0 -type none -help\
"If -allowcommands is present, placeholder commands are evaluated and subtituted.
e.g tstr -allowcommands { \$\{plaintext0 [lindex $var 1] plaintext2\} }
if $var is {a b c}, the result will be \"plaintext0 b plaintext2 \"
if $var does not exist the result will be \"\$\{plaintext0 [lindex $var 1] plaintext2\} \"
with an error recorded in the returned dict if -return dict is used.
NOTE: even if -allowcommands is not present, the placeholder text is still processed for variable
substitution and escape sequence processing, so the result will not be the raw placeholder text.
The result will be \"plaintext0 [lindex {a b c} 0] plaintext2 \"
e.g
tstr -undent 0 -allowcommands { \$\{ \\$var\\[1\\] = [lindex $var 1]\}}
$var[1] = b
"
-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"
}
-raise_errors -default 0 -type boolean -help\
"By default, if an error occurs during placeholder evaluation, the original placeholder text
is substituted in the output and the error is included in the returned dict (if -return dict is used).
If -raise_errors is set to 1, the template will be processed and a list of errors will be collected as
normal, but if any errors are present at the end of processing, a single error will be raised with a
summary of all errors that occurred.
This can be useful for debugging or when you want to ensure that any issues with placeholder evaluation
are immediately visible and not silently included in the output."
-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
-raise_errors 0
}
]
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::parse] ne ""} {
#punk::args::get_by_id ::punk::args::lib::tstr $args
punk::args::parse $args withid ::punk::args::lib::tstr
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 -raise_errors} $k]
switch -- $fullk {
-indent - -undent - -paramindents - -return - -eval - -raise_errors {
dict set opts $fullk $v
}
default {
if {[info commands ::punk::args::parse] ne ""} {
#punk::args::get_by_id ::punk::args::lib::tstr $args
punk::args::parse $args withid ::punk::args::lib::tstr
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_raise_errors [dict get $opts -raise_errors]
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]
}
if {[string first \$\{ $templatestring] < 0} {
set parts [list $templatestring]
} else {
set parts [private::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]
#jjj
set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]]
set expression "[string range $expression 0 $brk1]$undentedtail"
}
if {$opt_eval} {
#puts "-----------------------"
#puts "TSTR"
#puts $expression
#puts "-----------------------"
if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} {
lappend params [string cat \$\{ $expression \}]
dict set errors [expr {[llength $params]-1}] $result
} else {
#JJJ
# e.g i glob
#set result [string map [list \n "\n$leader"] $result]
lappend params $result
}
#lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]]
} else {
#JJJ
#REVIEW
#lappend params [subst -nocommands -novariables $expression]
lappend params $expression
}
append lastline [lindex $params end] ;#for current expression's position calc
incr idx ;#expression incr
}
if {$opt_raise_errors && [dict size $errors]} {
set einfo ""
dict for {i e} $errors {
append einfo "parameter $i error: $e" \n
}
error "punk::args::lib::tstr: Errors occurred during placeholder evaluation:\n$einfo"
}
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
#FUTURE: Detect and handle grapheme clusters for proper spacing
#Current regsub approach doesn't account for unicode double-wide chars or combining marks
#Consider using punk::char::grapheme_split for accurate width calculation
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
}
}
}
#developer example/test - single placeholder tstr args where single placeholder must be an int (unexported)
proc __tstr_test_one {args} {
set argd [punk::args::parse $args withdef {
@cmd -name ::punk::args::lib::__tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr.
example:
set id 2
__tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}]
}
@values -min 2 -max 2
template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement -
but the tstr call in the example does this for you, and also passes in the id automatically"
where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter}
}]
set template [dict get $argd values template]
set where [dict get $argd values where]
#set result [join [list [lindex $template 0] $where [lindex $template 1]] ""]
set result [string cat [lindex $template 0] $where [lindex $template 1]]
return $result
}
proc ::punk::args::private::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
}
#like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter.
lappend PUNKARGS [list {
@id -id ::punk::args::lib::indent
@cmd -name punk::args::lib::indent\
-summary\
"Indent each non-blank line of a text block."\
-help\
"Returns the text with the prefix prepended to each non-blank line.
Whitespace-only lines become empty, and remaining lines are right-trimmed.
Like textutil::adjust::indent - but doesn't strip trailing lines,
and doesn't implement the skip parameter."
@values -min 1 -max 2
text -type string -help\
"text block to indent"
prefix -type string -default " " -optional 1 -help\
"string prepended to each non-blank line"
}]
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?
lappend PUNKARGS [list {
@id -id ::punk::args::lib::undent
@cmd -name punk::args::lib::undent\
-summary\
"Remove the common leading whitespace from all lines of a text block."\
-help\
"Determines the longest common leading whitespace across the non-blank
lines and removes it from every line.
Whitespace-only lines become empty.
Returns the text unchanged if there is no common leading whitespace."
@values -min 1 -max 1
text -type string -help\
"text block to undent (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
lappend PUNKARGS [list {
@id -id ::punk::args::lib::undentleader
@cmd -name punk::args::lib::undentleader\
-summary\
"Remove a specific leading string (or its common prefix) from all lines of a text block."\
-help\
"Like punk::args::lib::undent - but instead of calculating the common
leading whitespace, removes up to the supplied leader string from each
line (the actual removal is the common prefix of the leader and the
non-blank lines, so is never longer than the leader).
The leader is usually whitespace - but doesn't have to be.
Whitespace-only lines become empty."
@values -min 2 -max 2
text -type string -help\
"text block to undent"
leader -type string -help\
"leading string to remove from each line"
}]
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
lappend PUNKARGS [list {
@id -id ::punk::args::lib::longestCommonPrefix
@cmd -name punk::args::lib::longestCommonPrefix\
-summary\
"Return the longest common prefix of a list of strings."\
-help\
"Returns the longest string that is a prefix of every item in the list.
An empty list returns an empty string; a single-item list returns the item.
A version of textutil::string::longestCommonPrefixList."
@values -min 1 -max 1
items -type list -help\
"list of strings"
}]
proc longestCommonPrefix {items} {
if {[llength $items] <= 1} {
return [lindex $items 0]
}
#set items [lsort $items[set items {}]]
#lsort does not seem to be affected by shared/unshared nature of the list - unlike for example lreplace
set items [lsort $items]
set min [lindex $items 0]
set max [lindex $items end]
#if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list)
#(sort order nothing to do with length - e.g min may be longer than max)
if {[string length $min] > [string length $max]} {
set temp $min
set min $max
set max $temp
}
set n [string length $min]
set prefix ""
set i -1
while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} {
append prefix $c
}
return $prefix
}
#order-preserving
#(same as punk::lib)
lappend PUNKARGS [list {
@id -id ::punk::args::lib::lunique
@cmd -name punk::args::lib::lunique\
-summary\
"Return the unique elements of a list, preserving order."\
-help\
"Returns the list with duplicate elements removed,
keeping the first occurrence of each element in original order.
(same behaviour as punk::lib::lunique)"
@values -min 1 -max 1
list -type list -help\
"list to filter"
}]
proc lunique {list} {
set new {}
foreach item $list {
if {$item ni $new} {
lappend new $item
}
}
return $new
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::args::lib ---}]
}
tcl::namespace::eval punk::args::argdocbase {
variable PUNKARGS
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
lappend PUNKARGS [list {
@id -id ::punk::args::argdocbase::B
@cmd -name punk::args::argdocbase::B\
-summary\
"Return the literal ANSI SGR code for bold (a+ bold)."\
-help\
"Base building-block for import into argdoc namespaces, for use as a
bracketed command substitution placeholder in tstr-processed -help text.
Paired with a closing N call.
A literal is returned so punk::ansi presence isn't required."
@values -min 0 -max 0
}]
proc B {} {return \x1b\[1m} ;#a+ bold
lappend PUNKARGS [list {
@id -id ::punk::args::argdocbase::N
@cmd -name punk::args::argdocbase::N\
-summary\
"Return the literal ANSI SGR code for normal intensity (a+ normal)."\
-help\
"Base building-block for import into argdoc namespaces.
Ends a bold span opened with B in tstr-processed -help text."
@values -min 0 -max 0
}]
proc N {} {return \x1b\[22m} ;#a+ normal
lappend PUNKARGS [list {
@id -id ::punk::args::argdocbase::I
@cmd -name punk::args::argdocbase::I\
-summary\
"Return the literal ANSI SGR code for italic (a+ italic)."\
-help\
"Base building-block for import into argdoc namespaces, for use as a
bracketed command substitution placeholder in tstr-processed -help text.
Paired with a closing NI call.
A literal is returned so punk::ansi presence isn't required."
@values -min 0 -max 0
}]
proc I {} {return \x1b\[3m} ;#a+ italic
lappend PUNKARGS [list {
@id -id ::punk::args::argdocbase::NI
@cmd -name punk::args::argdocbase::NI\
-summary\
"Return the literal ANSI SGR code for noitalic (a+ noitalic)."\
-help\
"Base building-block for import into argdoc namespaces.
Ends an italic span opened with I in tstr-processed -help text."
@values -min 0 -max 0
}]
proc NI {} {return \x1b\[23m} ;#a+ noitalic
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::args::package {
variable PUNKARGS
# @dynamic not required?
lappend PUNKARGS [list {
@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 dict}\
-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 defined_topics [${pkgns}::about_topics]
if {![dict exists $received topic]} {
set topics $defined_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_topic_prefixes [lsearch -all -inline -exact -not $val_topics "*"]
set explicit_topics [list]
set requested_topics [list]
set defined_topics_lc [lmap t $defined_topics {string tolower $t}]
foreach et $val_topics {
#topics are case insensitive. We don't expect function names from about_topics to have variations differing only in case.
#todo - enforce this by only returning the last value from about_topics for each particular topic when there are duplicates differing only in case.
#(see punk::auto_execs for example. TODO -add to template or use helper function to enforce this when processing about_topics)
if {$et eq "*"} {
lappend requested_topics "*"
continue
}
set fulltopic_lc [tcl::prefix::match -error "" $defined_topics_lc [string tolower $et]]
if {$fulltopic_lc eq ""} {
error "punk::args::package::standard_about topic '$et' does not match any defined topics: $defined_topics"
} else {
set resolved_topic [lsearch -inline -nocase $defined_topics $fulltopic_lc]
lappend explicit_topics $resolved_topic
lappend requested_topics $resolved_topic
}
}
set topics [list]
foreach t $requested_topics {
if {$t eq "*"} {
foreach a $defined_topics {
if {$a ni $explicit_topics} {
lappend topics $a
}
}
} else {
lappend topics $t
}
}
}
set is_table 0
switch -- $opt_return {
table - tableobject {
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}]
}
string {
set topiclens [lmap t $topics {string length $t}]
set widest_topic [tcl::mathfunc::max {*}$topiclens]
set about "$pkgname\n"
append about [string repeat - $widest_topic] \n
}
dict {
set about [dict create]
}
}
foreach topic $topics {
if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} {
set topic_contents [::${pkgns}::get_topic_$topic]
} else {
set topic_contents "<unavailable>"
}
switch -- $opt_return {
table - tableobject {
$t add_row [list $topic $topic_contents]
}
string {
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
}
}
dict {
dict set about $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 ::punk::args::helpers ::punk::args::argdocbase
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !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
}
}
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::args {
namespace eval argdoc {
#namespace for custom argument documentation
namespace import ::punk::args::helpers::*
proc package_name {} {
return punk::args
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr -indent " " [string trim {
package punk::args
Argument parsing library for Tcl.
Can be used purely for documentation of arguments and options, or also for actual argument parsing in procs.
supports longopts-style options, subcommands, and generation of help text.
"mash options" aka "short option bundling" or "flag/option stacking"
punk::args supports mash options for single letter flags that don't take arguments, e.g -a -b -c -> -abc or -bac etc
The last option in a mash can take an argument, e.g -x -v -f <filename> -> -xvf <filename>
Note the number of permutations of options with mashing can get large quickly.
(e.g 10 flags would have 10! = 3,628,800 permutations if all could be mashed together)
This has implications if we also support unique abbreviations of options as every permutation of the mashing
would need to be checked for conflicts with other options and their abbreviations.
The chosen solution is to determine the longest possible mashes for a given set of options, and then require
any abbreviations of other -options to be longer than the longest mash, so that there is no ambiguity between
an abbreviation and a mash.
E.g if we have -mash true and the options -a -b -c -d -backwards -cabinet -call, then the longest mash/bundle is 4 chars
(-abcd -bacd etc), so using the longest mash/bundle length of 4, we require that any abbreviation of other options must be at
least 5 chars long.
In this case -backwards could be abbreviated to -backw or -backwa etc, but not to -ba, -bac or -back.
As an exact match; -call would be accepted.
Whilst in this specific case -back is theoretically unambiguous - we still stick to the rule of requiring abbreviations to be
longer than the longest mash, to keep the rules simple and consistent; and so easier to process and to predict and reason about.
Although the combinations of -a -b -c -d are manageable in this case, if we had more single-letter options we would
not want to use a huge number of combinations of mashes to calculate the allowable prefix matches.
we calculate prefixes based on the flag names as usual, but extend the required prefixes of options such as -cabinet to be longer
(-cab extended to -cabin, -cal extended to -call).
} \n]
}
proc get_topic_License {} {
return " BSD 3-Clause"
}
proc get_topic_Version {} {
return " $::punk::args::version"
}
proc get_topic_Contributors {} {
set authors {{Julian Noble <julian@precisium.com.au>}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return [punk::lib::tstr -indent " " $contributors]
}
proc get_topic_notes {} {
punk::args::lib::tstr -indent " " -return string {
see output of:
punk::args::usage ::punk::args::parse
As a convenience in a shell with the various punk packages loaded, you can also do:
i punk::args::parse
Here i is an alias for punk::ns::cmdhelp which allows lookup of unqualified command names
based on the current context.
}
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::punk::args::about"
dict set overrides @cmd -name "punk::args::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About punk::args
}] \n]
dict set overrides topic -choices [list {*}[punk::args::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [punk::args::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::punk::args::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::punk::args::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## 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 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]