From bac6b9d31e20b5d7a4e9447b76be0edbc2dc5bd7 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 10 Apr 2025 14:30:36 +1000 Subject: [PATCH] packageTest and tomlish vendorlib updates, punk::args error improvements --- .../punk/{args-0.1.0.tm => args-0.1.1.tm} | 33 +- src/bootsupport/modules/punk/args-0.1.4.tm | 5473 +++++++++++++ src/bootsupport/modules/punk/mix/cli-0.3.1.tm | 4 + src/bootsupport/modules/shellfilter-0.1.9.tm | 6 +- src/bootsupport/modules/test/tomlish-1.1.5.tm | Bin 0 -> 51527 bytes src/bootsupport/modules/textblock-0.1.3.tm | 11 +- src/bootsupport/modules/tomlish-1.1.5.tm | 6973 +++++++++++++++++ src/modules/punk/args-999999.0a1.0.tm | 287 +- src/modules/punk/args-buildversion.txt | 2 +- src/modules/shellfilter-0.1.9.tm | 6 +- src/modules/textblock-999999.0a1.0.tm | 11 +- .../bootsupport/modules/punk/args-0.1.1.tm | 5341 +++++++++++++ .../bootsupport/modules/punk/args-0.1.4.tm | 5473 +++++++++++++ .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 4 + .../bootsupport/modules/shellfilter-0.1.9.tm | 6 +- .../bootsupport/modules/test/tomlish-1.1.5.tm | Bin 0 -> 51527 bytes .../bootsupport/modules/textblock-0.1.3.tm | 11 +- .../src/bootsupport/modules/tomlish-1.1.5.tm | 6973 +++++++++++++++++ .../bootsupport/modules/punk/args-0.1.1.tm | 5341 +++++++++++++ .../bootsupport/modules/punk/args-0.1.4.tm | 5473 +++++++++++++ .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 4 + .../bootsupport/modules/shellfilter-0.1.9.tm | 6 +- .../bootsupport/modules/test/tomlish-1.1.5.tm | Bin 0 -> 51527 bytes .../bootsupport/modules/textblock-0.1.3.tm | 11 +- .../src/bootsupport/modules/tomlish-1.1.5.tm | 6973 +++++++++++++++++ src/vendormodules/packageTest-0.1.2.tm | Bin 0 -> 11871 bytes src/vendormodules/packageTest-0.1.3.tm | Bin 0 -> 11953 bytes src/vendormodules/packageTest-0.1.4.tm | Bin 0 -> 11955 bytes src/vendormodules/packageTest-0.1.5.tm | Bin 0 -> 11963 bytes src/vendormodules/test/tomlish-1.1.3.tm | Bin 47064 -> 48840 bytes src/vendormodules/test/tomlish-1.1.5.tm | Bin 0 -> 51527 bytes src/vendormodules/tomlish-1.1.4.tm | 880 ++- src/vendormodules/tomlish-1.1.5.tm | 6973 +++++++++++++++++ .../modules/packageTest-0.1.2.tm | Bin 0 -> 11871 bytes .../modules/packageTest-0.1.3.tm | Bin 0 -> 11953 bytes .../modules/packageTest-0.1.4.tm | Bin 0 -> 11955 bytes .../modules/packageTest-0.1.5.tm | Bin 0 -> 11963 bytes .../_vfscommon.vfs/modules/punk/args-0.1.0.tm | 9 +- .../_vfscommon.vfs/modules/punk/args-0.1.1.tm | 5465 +++++++++++++ .../_vfscommon.vfs/modules/punk/args-0.1.2.tm | 5465 +++++++++++++ .../_vfscommon.vfs/modules/punk/args-0.1.3.tm | 5468 +++++++++++++ .../_vfscommon.vfs/modules/punk/args-0.1.4.tm | 5473 +++++++++++++ .../modules/shellfilter-0.1.9.tm | 6 +- .../modules/test/tomlish-1.1.3.tm | Bin 47064 -> 48840 bytes .../modules/test/tomlish-1.1.5.tm | Bin 0 -> 51527 bytes .../_vfscommon.vfs/modules/textblock-0.1.3.tm | 11 +- .../_vfscommon.vfs/modules/tomlish-1.1.4.tm | 880 ++- .../_vfscommon.vfs/modules/tomlish-1.1.5.tm | 6973 +++++++++++++++++ 48 files changed, 85641 insertions(+), 384 deletions(-) rename src/bootsupport/modules/punk/{args-0.1.0.tm => args-0.1.1.tm} (99%) create mode 100644 src/bootsupport/modules/punk/args-0.1.4.tm create mode 100644 src/bootsupport/modules/test/tomlish-1.1.5.tm create mode 100644 src/bootsupport/modules/tomlish-1.1.5.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.5.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.5.tm create mode 100644 src/vendormodules/packageTest-0.1.2.tm create mode 100644 src/vendormodules/packageTest-0.1.3.tm create mode 100644 src/vendormodules/packageTest-0.1.4.tm create mode 100644 src/vendormodules/packageTest-0.1.5.tm create mode 100644 src/vendormodules/test/tomlish-1.1.5.tm create mode 100644 src/vendormodules/tomlish-1.1.5.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/packageTest-0.1.2.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/packageTest-0.1.3.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/packageTest-0.1.4.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/packageTest-0.1.5.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/args-0.1.1.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/args-0.1.2.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/args-0.1.3.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.5.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/tomlish-1.1.5.tm diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.1.tm similarity index 99% rename from src/bootsupport/modules/punk/args-0.1.0.tm rename to src/bootsupport/modules/punk/args-0.1.1.tm index 91f29aa5..2d8de97d 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.1.tm @@ -3322,10 +3322,34 @@ tcl::namespace::eval punk::args { } try { set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg opts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + ##try trap? + ##return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + ##throw ? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg + #arg_error $msg $argspecs -badarg $argname + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $::errorCode] $::errorInfo + } + standard { + puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" + } + enhanced { + puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" + } + } + return } trap {PUNKARGS} {msg opts} { #trap punk::args argument validation/parsing errors and decide here #whether to display basic error - or full usage if configured. - puts stderr "PUNKARGS: $msg\n$opts" + puts stderr "PUNKARGS OTHER: $msg\n$opts" + #JJJ return } trap {} {msg opts} { #review @@ -3453,6 +3477,7 @@ tcl::namespace::eval punk::args { #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 @@ -3686,6 +3711,7 @@ tcl::namespace::eval punk::args { tcl::dict::set opts $fullopt 1 } incr vals_remaining_possible -1 + lapend solosreceived $fullopt } lappend flagsreceived $fullopt ;#dups ok } else { @@ -3729,6 +3755,7 @@ tcl::namespace::eval punk::args { tcl::dict::set opts $a 1 } incr vals_remaining_possible -1 + lappend solosreceived $a } lappend flagsreceived $a ;#adhoc flag as supplied } else { @@ -4515,7 +4542,7 @@ tcl::namespace::eval punk::args { #(e.g using 'dict exists $received -flag') # - but it can have duplicate keys when args/opts have -multiple 1 #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] } #proc sample1 {p1 args} { @@ -5305,7 +5332,7 @@ package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args variable version - set version 0.1.0 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/punk/args-0.1.4.tm b/src/bootsupport/modules/punk/args-0.1.4.tm new file mode 100644 index 00000000..95d5c702 --- /dev/null +++ b/src/bootsupport/modules/punk/args-0.1.4.tm @@ -0,0 +1,5473 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.4 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.4] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -default error -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + 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 [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "Option '$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 + #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "Option $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 + #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + set msg "Option $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 + #arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index a099c9b0..4c0ab79d 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -661,7 +661,11 @@ namespace eval punk::mix::cli { puts stdout "$current_source_dir/$modpath" puts stdout "to:" puts stdout "$podtree_copy" + #REVIEW + #todo - copy manually - renaming any files/folders with 999999.0a1.0 in the name to the applicable version + #(allow either shared files/folders or custom files/folders per package/version when in extracted form side by side) file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm if {[file exists $tmfile]} { diff --git a/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/bootsupport/modules/shellfilter-0.1.9.tm index d70d657c..92b214d8 100644 --- a/src/bootsupport/modules/shellfilter-0.1.9.tm +++ b/src/bootsupport/modules/shellfilter-0.1.9.tm @@ -759,7 +759,7 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [llength $buf]-1} { + if {[string last \x1b $buf] == [string length $buf]-1} { #only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b @@ -769,7 +769,7 @@ namespace eval shellfilter::chan { #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer if {[punk::ansi::ta::detect_st_open $buf]} { #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code #todo - configurable ST max - use 1k for now if {$st_partial_len < 1001} { append o_buffered $chunk @@ -778,7 +778,7 @@ namespace eval shellfilter::chan { set emit_anyway 1 } } else { - set possible_code_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of possible code + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { diff --git a/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/bootsupport/modules/test/tomlish-1.1.5.tm new file mode 100644 index 0000000000000000000000000000000000000000..536e3fa3bf724e2b979b4a297a88d29d74284f07 GIT binary patch literal 51527 zcmce;1zc2H+dhmS-67Hp-5t{1AkvNG&^a@-fTT2%BB26;q@*HUN{N7klyr%xq!J>0 zd%%EmJm-C$_w)VF@3$Cc_TFn<>$-E@d+oshoq5su+Pi^l?47_MFMF6BNXNol~yepV1 z$l2Ay1qSl6gLevi& zXbW}$LoDE(dO+=6Y()Tw@UBHfoa`+{M4T-g!Davkv(s-u9IiGtP%sSU;|2y@CWIGiO3kQmJQvbO>G8CzMvtn5I3CuF*~LYys}?0vx?V|y1HR}j<+V($hs z^@ooPKLPm9?_3XXg1`_6Kqc*W7$>a2JS@q zEMRt=AZ9mLDAXQ)4%EU146p;7@AyDqcMvTt z=*A5Yjq%BZz~1&y7!>s5_@Bp53pxkpJTyQY@VQ#sLqMl+fd5?JqW_8K+{NEdH?wfD zHUre=`!x_(SJ=r#r(M7-?45pHZ+fl+Ckuc{TNjWq)Xm8rc5>Fw&NxiJ(|*#ycda~k z^@%q8l{Ek{*AJD3qyEv~Z<&O;dO)mBXZKInah>f1(ED=;{6SzRDEK!jM)x<}finUH zYz)vESCAJNWM$z3%nxqC7H)13S2u_~U^q@b=emb0D{#!}RL7uTD;UU68YJ^Oora%! z!iSR+*u@s`F!a)Ay`Eei;6OpCS#Sm-*KdWI*&lH@`jQ_f!2bu;1?w+qgo&7JzT@29SaL;3qTF zd$ar_ac54K`Hc>oPUJhkC*JA1albF?Hu8!{eB|9|Mt5c z{Fbx7Ujd)Kla&P&Y9>4|0ivXQ?W{htg5?gr1Gc7j;A*aBhi zEc#Q|ZFH>s+(D_bI;sy|(;XRvzL`2{-gkK9f zi9)V6K-@k_Z9qWg0?gbRp3waG3UZoq{dR6A$^v)MX26i&V+z+P;U{SPSpClfF@;AS z;C!$(2OtV~Qgt?X{B4YXj2>{x|4IP7r|)z8TSq_6KNvjV8dX^Q;gsuNspfWpAw-@~=w_niPq zDiDu(xq10GxP?VP=R5g+FoENSi8C~!QgrYVmgzHFae1<*aZXwvO>74{DlY# zB#=;7Af@_&9Rw(s6W9U@1KGkeU}tzr1iV{=oh*EyARrOTP(Cl{J`0J--obUof1ZyDk1v!ENz{Y=9kbicjv|L=LsszunP7RF~ zB5)z9@2W z1w`j&eZmRH_sr~6ppGuCUcj>CobJL^)YSt9fOtfcFF3 zKcIG}PT$7f8&JR#BydCi_ksSNUi^UY&qq#WdRD{#F2>(38vnZZ`yVBIj)K!10Q5t; zC*pv6`~T(O-vtjy?v$#N{(#VDeCDI+zms>)*?72|BKi%Uf3=YB<&$4^5*r{uov6u= zwKlvw1mswNiJTN+P6F0x`U0Xqlhpk)*58ZL|My;i4)8^%RG&+?Ku`}$U?l=9nq2|Y zw{Y@;hf{bcgeMySI-tV#v+M*c$$|0%d`W(qlX!w%?19q&hx)5d24p{Q?LEB|kRm)3 z|CXokMTP&Rl>gS{zh;SaHWp4!mOy$7Hz>IC2Mq2<4)wR5;D$n{F2f1Z2hxj^ti=k* z>w)MAr{W|Fa0Xk$%Mc)dHz{B)N8 zYC!Poe|X-%_e_y~m126!arB${8606g??rE22%efX1KpB5_&+(o0 zlcFPBD^IBhbn~QUYz?yX0rEr_4?y$+|y{uL0_iIe+jc<_ae6Hs&F{AW{xqx}m~ z9iX3+YB5k!1_8MdkVL>G4~+KRJb;B3JY@iSxA;*Mh9}v-YRPZ_KUw^4YbPaSH(;WG z`F*b~1L@cgsQ(V|)aB3vRQ^_};dA&`Gl8D~f1NC&h%GlkxWAs=^_yV0sCbdh%gZl7=dqp z#2=WeGf=X!tPYf;=5|2o8 z5~<;rCqsof$oaIEz^|NEBlA>+zu~*wfniFUtLE#ea?_ec2?xvPX6;P4j4xN&?rfI@ zDDQoJNj>{w`?6$MT7y64m3J&CLU*F3XGmqmkXKN~K5mY!6(ze|xV$QVz-OEI;wp>S z>&G{_dStw&-wQ zm#Cwjr5?L9+AD?gJ;8c-fTXKfzY^Q1jpNddxw#l5?+)AR2LzZf;SVmsA`M?*jr|Bp zbwwIJV+`mwh%N=UYiwVYLAJf#|BS4Vs{yH_eDGo<{WzcCru}U~lniu&_#Dya#nO05M@%SU8dPHmn1YORG&hn2&o$Vzz zSHA=W!nU1xRMP3TFo_L`DAOC2$*(1t4Vfk0!ZKh9QGQguMqe1y)ON*yE`9ts^=i@n zhn;%?{R;+~jzY9?kL+iPFFcm>;V<^Y_fmeFG*04NXv#>tpBVdvYoASjFlvzcjRqS? zC4I;@R*=a-Q_2vXO}1*#Qn+Vw7FzGzmMuHeSOcx1;m0x)dVjh9(}MV15KWII-K5S? z-cyU7mJ&Vb*I}2oZcjdVjFG9#5aRu2K$x@a%ePdwgBe#O&UNFb!dN>=eJ?-Ff*Vqa z+Hocf8gop)M(B~JSW#79yU|ILZuv+Ld8qixvrPz7O5GP4o5!4#ZQPvMH&+(yxR=qOE>&_<(FTHMh-RtTnPdq z{15OFLO}UX{E8X8#02#KiXc!fOQ4d=3IBY24D@mV3E@}o4a^ZnO2+vyMi>YPcESh< z*AP(u+uq@s08sh&umbKTfw|6o`aUQUFeu_jV`nItFu_s7(IwL{{pp8@hFw#aADej9 zhE73EEnS5lLX1Omp2r}(Xt(pEFE@-j4wy<@ro>vHpMKcqRNDS7kKqZGxUUge9PP4c z70a!(<0d>F)Q`yNZ2mB!N@4x9mqA>H2veL4lcAsSXPMYQ%Ly?8mnu@~ryk`$Pka#^ zi&X7K?tTs0j2)}M)0wngim^2 zH#3pvar2Q4`M~y4V^Atf+@*`pwhW&8n`h$&4TyC}PxWp@lgpwtbJ2gn*D4;nvzmF! z7m0f4lR!maG@80ebB5JwS^2Jg0PjT!=XT!#bL!8E;x1U)x3UCMokiJu59e;V=Pq65 z6%FHA;cyVf4NY%t@n7|1s>qCghpt{;Ymu$ck`u9@l*M+m9={@suV{fmzq+sG{4Ke9Nit- z33l{4D0O=LUaI+>xS6-_tzDI;sQK>%%(Ax+X%4^bq2OOhif*~ZG68-dC-j0L2TZiV zfLp-Kjf`F(Re-e+id!BbGBLwEF1cyygCsss9D%#8OE_sZT=qUtp(-GIt|#W%-JaP* z%Edx{B6nPfOO)5ln*5W%9Jw7=& z8c;xeXo#Vsj_(I-wAG$`BpOQnh|~kCT(L0iqu!5Z#-nN{10Rf%=CXOefB6WHFX*sU zX4akE>MgQ2T9CCwVl$dMarA|Bk z@XE!fH4Y+gmvgl4_#S_IvWubbUghQC;q#;n*8X5DN#a(L%cxjG+btwYBSAq6S`a?{ z6svpPfR|$)x_03l|IC0r>-sFeg`&yKy4mL$v(GIWqq^%J>$Zy-qmN?!Da+X%W1`(? zhiI}EWV>?}y|j+=d%k339bS*0T-)}!+rDPZUgdeO(5niDuWaax!}m46L^D1GpY;Z< z%-})lEq}RqMLw&+F#LDSomXR#YEvXSX`-NA^n)+JGX=qxwv;M?&yNkCRbIPhhu$eR z&#t?RVW2jkP}H)408YJXq6EtBEx??6viNk$P0*b)Wmwd{g7$9j{&s zt=^3Zr4EUB#oFTBFJC6<+j3+kl8)Ni3u*GDaPLm+rQNZ8kMO1#p}7%x-}rO#C71Fh zaYs?o(XDqr9&g66ig{nI5A$T+WfkOS*PN@!GMm6CF>{f_Yl-0yHhA+u)?k60HF&yS zpvLW9^@H)vjUWni~Si4tR|Ggw6a_#o%rnhL~?QS5abSx{0@%8m5<11bv?Vuj^W%r@Z z0Wi|h74;)%_B)0Cs6tWC*IXE(^WKhb%M$t3W17(sovFe#vz?2HIP7gJ{fcqof#ghk zJZiiC7G3ti>(pwV#d5cYTeLn6FB&5ZIXlXi*FJTt6Y#THt9$W8ktM$1AgX}(y{xKP zPE?wzm!Y52^~H*GwYi8o!6%!%CV93;J4VPa@=_BB0%YWwX1H;&DjGZgCZaq;~cBLIpUUEAAQ_y3RDOUE$*V ziZi)&kWH+cH#eo_)|<++Wh>A43w!vP0a5hg{0@db+ZPxb;b_$*pYz zbsjvYj!+wCT%cTd6S4*?P|tWzL2|?Vj)Q`tL9WeBI?)k9PXuqt03L65>E399S8P;j z=}Ln)$S@lbLv)b|7X_dm7Asv{h;0u;z%O~W%L0RltVpZPzpXlzE0B7BnZJu4V!MW2 zC`}?FaqQ;dv#H9vXahlZj(4kU+qurt=B-ap#uup38?KrN)-5FjEZ%UT2%e2tN}Rl~ zU_Q(`{2_I^^PBC;qrRDR$#0({`4IR@=|=pIOghFTSd^;n!0mJTmkPEHoZQn+el-n=|_5Nru{eYzC(fHxsXK8&4e$@h?wh ziF{z@6~^L@S9e)bU(j|gdUtUU)b+XRak^Rs=cR`o5T+ip&+O9?XjuFA=VowLZ}p4b zq`pCG#~1Cf+o=82CnkX2_l5L8y)E<3v1X&<&PRcq8DVpl+qN0Q#eUA|tM13dg!j2H zhMFiLk(3s?R9v-W<1?S}o@sG5NbhuQ41d_7FScYaO`=A)8%+P8vi?*0GvPkYZdB}K ziCCK6%P=o>Q5mUFby19G3+(JS7uA~g($J}@#xiO{LJw6V7{2P_*L!j}s~|`>s$f6Z zLBt{xBOS6ozU~;Z$T^wMz}=Xud!S=1IN?>*nkt`GZOWb^g;LYXGkWFOrAJpbtG!aM zcfthk-L0ja?I-P{rUMU7Z5?rXI%`|Elu&Ez>#&=D8@&2%leoF0G_Xc!+9aK{dFDBR zXht~BvWt_N)sr+ffy8kIEd~m5-SBh}-YA6^xK2T#+PE>i-m5qM6Q#bsnHh5m>qtXJ z^_Crpp2y9?ZdZ36wy%Cv+P;!y$yc5rtwtQ~x^_b*Id}B`xc$M&tYEaQ5#!+lH zsXO=h!mn(W=0eE1T-g`Mm;Zw`_}N_98tnOFfo|sP0c^7bHlP8U7oAR0SvpQmw(qO= zAMbxZiPOfy!`sQ;#qn&O-NhDZG|lRC#|EeljA0=lDE{|(HUubfSOYt3+_--JcQ(Jy z(^qv}5X6(vZ?tYQmN@4`JEDBOI8hwg00Fo-TZuy%Oh|IHE-I_VB{@hm z(yG;U*R{zf(eTDxNAMI6CdW{Is&RP{zQ#x}c>%*)hmr2V_jUd|j%umQ{S0>ZAch5r zu(VBw^bB=_M_pzH7BASkgDtRcB^rLwu5M|RfvFeEyFb29c@uBLS>M>jNYBkyZp$?% z)o#-v_XCdHk{)I(^&#oU(M$ZFF}Z>s-o}s?c^M*4dxKIwV(Ijlr$9tu35+?H}A`#zIjqYwD(bL_aOT2`*6}vm%0;o zF#>rcpNxYI$8d_Exs>2p>?vuGT@qe}pA%`m9dpV;4yiRd^YCk5wqX>lLT-st^RyZw zcbZzKZ9&qjd8s3a5^rzoQ0;?+kkpRb`?B}2xyFuDz+s65Lnz&_uW8J0^t;W>r`Uw& z2|4e{$0xL#1~}!HysF51*T6wdwDQ*8E>rnH<)dTt;0WGLdq&+`9x3^&ihFW~Qb)lr zIkwakWQE`MPTmkWs0vnD<+-B)nOUrntJ&|lx4e;A(p4hT}MV~N)djo zvW_$DMcSvVs<_s#BDuR!#9eogK;8ZO$ydaK_U|J>ZRcsX*&ZH+e_MMU+s+QfDXb89 zRVq_39~qTLW9u8B@3KoaSdPzita9gS9eXo-V0Y^MswL`8{+h>e^YQBejGHgEuU3uH zaCfE!bn&kBxILgerXC96e1W}I!nN>ZRq$E)vH!G{cZAX|nMjUn1j^UPMVkffP-~e_ zw$8jVbfEQJoWpO0hcmWIQyaMhn`O80>Y+zCm(%B-ua^lfU`*Giac@R)Dj1LiTo|sI zG(h(c2BHW@hd!}%IceCF7z?e;tFesLLah6=@c$rSn?!{+erfYf^9V@zC9^s@> zv@5)>4<-_^XP(xUwdlHBM3`q{h=(ECaw#R6?h;tiM#kIaHW8nS4f@E@+q>=d+Nez- zaya%hLP~79dOTzskhibZNG5$$b#p!g|8o1?QH6`_4U_YzkKcb zbymaDc3S~Sz{f&>cKyHiwLksXFOOyhzfl3@vVcG=e9T;J%hEP^ z(JR-D&@0d@Ko|@c!AOznQBustP$Fd;e!l@>0U^jG2+JiP%Ox;)$}8Z>Gvdh;V?4pA zXfSCoIaBmNiefdq@rvRO?F9sc8KCL?5odfBI@FBk1oH9mN$tZlLHt@fH(vPeVU&K~ zZHB0Km&>_zEDJ*oq}X-CRUyu$BA#G!`ER?Kl+0+|Tb+&T;wx3%Uy<*Xcjk0dc3?P5 zPjf+)e5iD=J-}9PlRXvtokl(wg8MTgo^}N2TA5l6MVUl3-6OS*vDTyUb&k&_h|pRj z-F%M5Ur8bVxX8P)oSn3BKVC1n$jkn{F6(WR-5S3uUUr(6y9X8i-uTs_>{v@P z3c+GFhvb~Amrz`Bj6y92G)1GCJ99l&ebdxMAkQ@V1?8roeH{!kh zLd$@#PGcR$$UBGw7kJ;++BN@0IGI=CT^IqutOLyq0r|g;;s1kP{SXd^E5zQ`-o?V{ z_!t-mkdfnwjHHg*qj|k~^7kF;U}!M(WKIs#;9FJxSLLi(lvo*$o0x>{Rixjo`LEZC zMmF4EAoc52WmjR>yvDTnjdq5mKZ`Y+(+M4J#BLxsHqNfS-h2g=&Tkf;xShow!vQn93- zuJaB1~ojbw(pOZ+BGe~^7%O-e*6Tr_eW^_Tr$1dJ&8t7uFHVE3Cq zGx+c8lK(6x_^oRw@DzX@+>X4z*DdAaDsbAkvE+7dgpKrVpvK&|;CT6pN2I(`@Wy_$v~Z-^GMgEhwEi)hL%cKiCfg?X{nB{m$(m5@&#xX|A(}kQDAso_a{Fp-%yM1 z&f${mBfjBuStE$PeQ^?bb61E}t7d!k(|%j%wk)ATXoQb)=6Vapr5E1Q1S$tIDT(MM z6zBvjIsT(w-lQGw2shnENZB~t5U#mJgH>Jd-2@X^t?x-8Ulg!^h->V0XH8DACL2i& z$IG+)UD6S9hu!uLD+8k`qoSGJV#6WP4j{P zKMFwmqyE#C@!=*`a;4d|BZYN&8rsA%ndnE4zFuO9Jvch@WA z%Gj8o-b1I`1qnP#&v>7ZbX_>(li<33ZT%xy2mq@Ev_I;T&H+9nQotwu!o4)V^aFX& zMoT6fIa(Rw^H%`!?Uy^4DxQQW2Lz}co&cX)Icagu=GdG zZo~;7?Cw_Vn;GRXadzX&`Z4m7h*>lxYG}(FK~@|GO#uR2A&* zSMa%^4Ai5G-e?u3$RFDxtf1Gx?Okq7Fp-}5+_+m6ZXf){P(=MbY8M{;rI8$Tjy4Es zL>`7tC~C>Kc(oo~lENX*%_5JwFhS}D<1^Dk1|&xM#boptm=-tSV+{VJ`T)WK!#Dk% z&y`{mDqKQR+JbgIl1=7J#g2-&`kw(>e(+zxfQtGzOmdVjHEc+C_3bCo(wZ0j{ zT#XCZL>{`f?{BA!+$vK4y7h2aKL?3DQ2I$L`@`g@$Zy}|u6IJQ^Y4qb-^AQ7zxa@; z{A~{MCy{H2@AwTSS|XAjp?e44^Ost%yBcjd7L@uyhj zeDK1@wVg;NvBti1yiPji5xSPswmpR`2fMlKT1)T0ZjNsA;R7Ov`bF<$pY4HXA84Ik zf6Hwoet}hOd>PbXN@db^H?M#0qrznS!OhO+3-8Pc*F7*h$%jg{1oBwp?)suPr(yUg zH=QYFz`1`YH9>O`a0Fri_ZELrwf@5WPhI-SKK=CELo8E7-iPQk1hS8c{O)+xk1-nX zN`%G-)s*q5r0CgSdO76Z{OK_3QYGhupq$6=)jm{J`d%Kf*S{CKr$%_mZa+FI#fFCQ zIobGB{Gx~0=;Cq+<2!eh_t;2YWbDe-QqF4vNFvC3W#%of*YNE^<8DZ`o5#utE=t+k zC*!bKb3e|jhzA5PEAtT1)x9#v$2_=uZH)Wrs-|bhD$}u*+danO7u!=DB~G}nW`dP7P-nrXXAncW{+?0;;rX#fz%U}0%=nzIXfMx0AJ6uO0TvdiNESM7_t}Qv3RVx zggs&rXqavGi~MR64nxaPR7X)X1cX3fkB#1+TnKz8pZ7cafNY-_IJ-^?5ga`>C2c>UV&+G|x)-AYf*;oRaCWLx+hwsX z^@&K?W**6DOO{NQu?kFkUeCBgOgJ|dEHwO4u&rCvp81O9+LgDdS_Z-oX2{n-X1kOE zdRneh-8WrGa`s!do(sNY;zT2<3Tm3gFh0al3Atxfxs?7vZ`lF4tA`gacU*+u*nm3cDWxJ;p%WL7>Rmv_sx3gYpwogNPV<@=3!x8 z-()9CNMo<}R~{&4VXCLxt*=v? z&-HY5^K+rXL1?Wu=k-$f`mojuf;Nw{A4LBSyZy+yyU*a-H}mI%I&UD#rXw; z4~j$FWEMgWijr68ExdK6y5<7~Bf0XR>W3AIB1U|SiuJjV z5=qmPt}XFly(Z*v9~kl_)0e!YRs3K$U!Gq5PAg!s8|JFmPbEPHJGrxa;vmyu|h_K6+#FmF$^7*()zx z0@yVTH{G`)F+~Om@^f$ZwiyLl)67-d;|R%(p-v_A$0&RdIiQbWx&>yAtjGRP-t|7Q z^U|XmI<($q^!SbekBb&&i_nofB~gsl1=Ib)@{J%=5AHwFRiC0%C?GJoG}e()cgH!2 zX@H8qOW(nisfpAuT2ZECukd2rXAr?ufw`<5iI8to#;dvrp!}j9zh@D3Yi{oYb27h2 zkSSzXac$K*5mr*dwFBSEr|I^YdIeiSIEEp9R@!v{hkJ8Ra4Y}KQWvPBr z!HQz)@OMPM2en$fef2e@@Co9KF>XinYrElnw@Rf)RWGc0KbeqnF-F69Of&bo-am=- z9v8YTPvq4T?m27NcT_pt=JkQg?nS%_K}qG?q{kY{1uri7m$>f;?A>)eTB~(zf3o6s zZ>E~GN**n%3GEe>ls`w$Kc28nff?3<{p3#PU6kp}Mdpp0xC@I2Ht8{s7Lstf=a@-j zaVxWWau*{HU3gdJI=6N}SA4`XDHc=FI%Mm8(=*l8m$_3{A%&h?CNKjvGKuNgQM4lC!I`xjrZB_ljyojLaGZ;dzOG}B7Y z=X23*Un;O$iC^Kqm-Q+_1eA8 zh07fgjq%a}XiXB0GzTP@@|Mvm^MpJzlkA)q(W6}SuRI&xK}$gOCGIlKTV(So)~0z@xvT4|PM@;D zxooc(^oYXdt6P<)LRvW{E9!ETzo;CJv_Dl{+|=9JpcV+u0xb3tinmuDl0Vwrc#`Yvj6WK~+~QP5 z5yTj~D<`(+(y~EZH#bVhZ$j5jc4Rr=|DmGcaMQ@{vx+CiRb0V^UTUF)uwK&Q*#$T1i$ySn9y?KF$SS`hn?4BP%1vt z^jM00a=VS(luJ`?Ol>=EQnzPSCpfy8dKcxEv+(?3#8gD-ot;>v+fMT9dzdMc{ULTW zA#=q|?7EL(R>#kMg$zdhDwTvY_FgJ*$;So;%3PlC3!I6`JwCI-Jy|btIBiD*xq3U$ z{%Fo(1MKpL{U~0Z)GR4uRB_rtKt(LGO)C|jSnz%*^2>Wjd6zWVR>eMRYwGy510uL^>{;TlOL0$wm(jr%O{O^4xMaz+mD{*@BC$AfzVy z)Yit&k3uKWkWg^sjUUmE6Xu5H-B~{**6!`)M4cEAzHjw#&hM%9iZH1Xiajj@cUR!A zybaC)Muo#jA~649pqc&23fMUgey&7ZNn-vL^aRoRuio^s*8Evi{WgL{uz_sHdMk&}R_jhBc-3e-_A3yK9QWp97WX zRGMcot~^EtI9aV@36efKvzT+nW;dKCTnP|8Q3`k!>A&8^`Ol>fI}3>QnL4TVEKn`d zx`~*#74w|Hj{(^jIj`$bD=hg?>@z`FVoYy?Q`r3BTb;1M`C-~HNV%Pgga+b6l5BEx zgfp58&!Z5!AEh5ql&NsoaPJ}(p>*N{VqKr6Oyd|a^d=@gF_MlFzs=w|NnUDw!?1A_S zPN`*&+$+%}%GA3T%rFw4g%xGJqpF!SM8hmQg0=lFg|1$5wM-$0e$cfC<8j50=^j~oiS=E-UD%7r-Q?TC?N`UN$tGNh`dO+uIs4KE~=(mH;t*{4UxGs{4QKN zH(VIuponIVb=5Xt^rHcF8i8ndmp4=G^;S(R2qB@emHYDb8FwW~YwA`$flCBxBGp)Q zK8v&{e3Hiz{w>yzh-HsC^jdJ#t0U18uSr){xy7dWApc17u6DJcAdV%Sdh2bEfwC;Y z_v}G2oK%`o^F1vN-Y)hX*Kb%gmEpX^stZW=@G}X^`Y0mGp8e=I_o){ms^K_IGx}9f!!_IUOZ=S|+){BG78GEao=qyK z=q*Wi&o^)LG!X{;$h~?6-7QpiTdeAa37#Q)x9YD<=QH$Hy^ZllPW-gGeeebI^@G(< z%L<2**O!vMvxMD#X(u;J{B+3VN9He*J4)a;}hbl>yEAbfe#H9O=gtT-ZQX zPKZZ!;GSooPr~bvRU3@bFV?X+v(;Nf?1cdztTpJZ%vCZnaimFEZ7Jff1Lp9MRm4Gi zdly7`ACd{VhhnR0h}eWoFggJxy@;It@!6^fM8%V9_s->b1U61C#0Uu=4Ib>N+k1B{ zg(G~qMG(YznsU?zUYaQcyTn%TZ9xX7oe)>ct<0NjHk{c^O&=axU0Th|)LcxElcq(L z=`h2*exaj>#YQ#um3CmoPJImtHG$HwP<>NA;w#BwvQ}R1PgCpC!c%M^YyJGnxai*u zbbI`yF>_-ESV!t?mJ2N7W}6GqTU8G31{Qmk#Fa!-$|g4@nQ*VL=hvz#4H}r#J-VVY z=ryi*#IAuJs(dRo@?nJ9Lnq=@>h2nntzpZf=I1Co+0lXtvQgd2p2XSse6qKd_!5+g zo%%~3mEZ|rzlqYG^s`w^h~&A#%6?HjM3j75FImJo$Dr)_#YitpcZ?BF-G1Y0@>r1< zLlYf7AD*XUXP|x?w$Ih$DyhM5#@pXVCtt|UBhA=K36pH*Nb^$gs&u&a)xF%*mg&uA z!E(pA`^NgFe19eRC6l}g_NFIR`rCcOR>*hAwfYQe@~CYz<3|bX{10C^S!Q*TyoejQ z^={~eL<&|xzuv3;u`EwQV{H*X9hBNNC)ZaLrqZtk*$EigR2L7V+j5`F@;g{&r6MPD zHR4@Q+IHcVGI%q*aU3|2^BPtzari1`u^Z%cSDkt&E@-Ye!Fo+^|Q- z8!wg{lN#x*^k=*`S1vr>-!-`@?(NAc^}bBjB?I@xTKkUJ+dL*N9+P(~hn0eY&Nkr` zd|w!<>#~8Z&e!BZ^11Z&D-&k-M0gR;hD~@bAxK7g{Q(d*)d1zz`IAuyc(nCbHg$5J z-XpFao|n7{az@BHja9ZAo=CUM%oE4`zwX3rN&;MG0Q zUuGHRY4?8hEfk!c=e*cqVNZ@|fqHFL^dbmt0U;(KM=Ix{%-u<>!{LUhgBupPlm~cz znL_EVuvC*J`qqR`g&oN+KzHK{!IhTcS0kovt0huMAaO6Ks1aA2P3gBMFRc<#*7L2Z zZ^wme!f13hZkPa1VBB|}egbT0tqs{Ob!cqz^$!>z|3y+c=CM)|$|x`V#uva5g2taD z$;swd?Qj9{OyeRZ$#aq zM%f>fnV-1+bpK|fK-eJ1D$RhbL(f=xhb2chTX)8*=5?h$PNLx0fg6oJ+x(;yB1=Jm zq3uVVbV`$P>1tgoRr~A(1B7BXm9nSU-e)uM+y`%fDSSsPLEbqpQ^m($nHccSjy=p_ zGr0uytfOI3mgykvka6^IVjT<637;*I>5SpkK#@_L4bfhP$v^vwJ6B_lCPrgx`TVXo zizDsW5m&v!ihZl}X1M1^6f!PuoO?1`I9)zCTVk>Iz+!0?Tx0R>MOdD`XqS~dV)4G#62E>jM zq&vkB38~54U67&8{g(Z3Y+uV8`3G%IwX(H^TU*;AT-%A+sB6KtyZCS9HQDD4^Q#aa zJCyPaD|j5)-B_yjQ%~>j0yQUCi#`*gs!8AQr^GgwnTfIPPAuODGTdk*+3yzFKzh0; znSbfMpPx;d4c1}71q$)_o`e`Q*PFs$WN&%E3Ta+*ZSBc_La2=8^i6d(j41rsAl&r3MmAQvr6N{l63%mtY4Bzcw zQ~m()p1bp|QmNDh_5r|GNPWuMN@~}7d(T-f2EwrtmALyZ zutygGcqR_GV*$AD#_sYhhTve`HSN^#zHQHI_?3Ot=9;!Ot8hii?F3_xj_Q%xh?|6Pn z@jRk)yZGRcqQ^|%qytbof%ZrJ?CDP#{z?zvy2KI3gW1MS6uNs9MMo)OSd<~_uBGw( zg)*8_1TMMLR=JP#w_V1(A$PC0o$_~m!8(_~M!B~{1gTKQYd4&-M`8&}(7l<6gPBT= zOw{y*-G>X;z8F*XImHU$7(Kq_Y2%C${k*8CPw3^eHlEwfB*tLL3%QudFY|Ibvyw`# z@36JEew~WhC%!zMgtd=r7xPdIi38z z;}24P%IK6Ays%xF1CvoBFc#`(#ZpzO_+qh{zipl*p1m z!GZT3_>G(1ip0TmrDP^*b&&Z7R+FDu^e}-rAjw^+Rd9Np_vjYE~d%kLn%S#dT2(8T`{`Iu={)daIr3a70JJ^O%z^gDWqJzyr%bh(IavTl zsRKC5io;iCVX<0gWVmAM`vGKurOpMEZZyq5d#azF+-7%HUyuF5jn>UeX(lyvoU*Zq@ym_Lvp3q9Zxmpm z+!wM%RVjEAr?_fT)fwu8H58s^7sN3j%v9?F{Fn}_?WOEifd>APvi-GZZ#M7~E_|!x zb<0H0O!&ZItp_Ut|+H`rE8}AXZ%K&rwWi=`% zncW?={Bf5E?K^z^>W!9L9qK|lGq$K=P^eYWSK>?jD*m9Xc5z1ngf#JtdxM*RM7Q0Ml=`5^sCugV-h;e{9L-uNcAs0% zJnar=$Ltc8B_+TPInea~Xx#hmzxcmv3y_>&KvV@X8J!4CRv-*VYHBg}=`(lhGjl3k z?bVw<8<63^=m$XIRB$y0n)&~Q8lM6?BQ`)k{srICS%9K!TL!(@FA1XnaD>2hHo*HI z_YwkT@I8O<-$wPc0De#!c0#0c3=e!?uKaH1JX^0kq9DCX>lg!v3ri?TVs&07m7+A( z1+J$@yMAmG{h@KCOFnMmGCP%sF--ib4~wkK@{o2&Zgm?#+{+dnLy%yW3@&AMV*To3 z*GxJl#cwigMQ9ms8@bH~lE`Rr79DMEQ_Wo!8sOFx*gR4nL z*ypWGx=(rJ7Qg})z=qzRw6fD@5`Lyma9?j4CrSX{o9uVrQjzFAztCZSqWhd#5gvx! zGx0?1(CjV03CivaMK$OPg0jzXlf05sV~i3)FtTI`_WH7j35jQ3rfyPhbO(a1npdls zl`Dx<3*?!!K6zi?lrdlnm@L6;Fms$oJup;#L2K2sWBVeYgOKqJO{X2MP+q>U7f0Af z0{ucKzcagM;QIRT4HhQ+P80_~z#m-~oFm|;x|+t-;r9*3ju$Gegc8 zn=TqM|Dkxjrxa$&%B#HzG5<6^;=q@n(*Ql*4bwm7hn$C4U^OkM#6|I ze-cc`&yjiuq?wria5IuMP2$Rdj9uN^Hv?#W0$KAY2UFLS7chucsgoLe2pJzs_?2Cv z2qxuute{e2E3CTwx#LU?0M0{U$jqQDzyo}f<{#Z_{GEp%LI1>`M5_;LUyEYV9Mx8d zW6_LSDk|44(wUD^AlB80($(mD$)&8z+^wX`&8ecvtbVos>MJ(QE_OYoZZ%a^4n+4B zquAuX1kbm%B+K#uavh-k(R*p<(EpU;X{`9`EWS@;37Ciee=-kH`nh@FvPT-NlF9^i z0*^n|0!yoF|3AzT{)Eu42ZrFE&iuAX*7v6%Rhun~y4(m#2LR!SOk%LMIt9s_S4xAOb03B% zv_BDOeB9_<_Z37~r_eBL4yN${J511-jM?O^rL4qm8R}eb#3RnMV;F9W#$6?StXs5V zO4*j@Z;7nZT4TD9w)f-mTqFh4d(F|hfBdS;z-SA@+R!o_SZ6+V!cicd* z8rQ92;NaND^9&ITka@(Su*pnC&$#F~W1wTi0s&nW5Fxfqw!`U3d@j9_&N$>Sbld5i1*Ox$@^_VLk~ zhyiG-^06Lf;>=Y+GUWV&EI~e;?>l6uXj_0niTcoD z%oEJ7@(p>k>>vkkj+Z@lu{5$&SMo?SW-J!nD*aeF)XHeS_=ur>S>tadXgaEP*m+~F zr^!FVuVK}=l6jAYc&&l1O}&>njZ+Qvp@Q1CY#P&-wg%YQZnU`0InA@Q*yW#4GN;?tw3;^es$EiK90Wl3CXx5E-i#TmovY~nCfaI2TGXg80Z zoAVr(+pzh&dhmAmwLGtLSG1;Yky=d(x0t{G6#Gu_G{*5DjjyO+XC#z*PMiI`F?y|t zSlJ!zggZ(oq5{IhyqRxC7b>pChRl%G9xpgi?O$v*)>ifs;_68QqZuy39$X+UMZ4LQ zwqc7vFo(FJF%)vILigZW#Bmsj;0tILZj*e6NW4|FU0NmCGU?0e&|Wc{1k=cBV#0*a z>A1>bGc{wBtxHRh2MqDIXS;aQjckI1cZl9ZT_(ZNatRjOyRFvgxJHgqrm zN8b@9@O9?t#vLX{iIj=YDFg>;6nfvuCo=mJHtQ*9_AzNLG57;X4 z`7+dNGX*xy_FBtcs|gRa8f&(YDIqs4@GbCUQfV0nh(8dN3=ctlL|rEwBMtc=p+>Cp zlq!L|A-&gpT23QbO^T_W++a=$cmHW+(mSaOS87nxCbfGd>B1??LS}>wsVHzSCvQ&h znCLR1U(XDMsP)>DwUOU%nPAC4YL_=SDuH5LY}QaHs~N8!#u_zVWMIh{)*#aCuSb-I zxaLvP&aH4;(+NpV_X*rLz0g5d!rNH%c`$^Rw)Y(#%ZTs0LLOXt^2Y`VdHQx*Lb)$n z%38CtQFA0U<**G{SoojLI@)~}m%^9M{w$HZ@yv!kTJdZABgSiQ_z&l=Rm&eIJcCI# zvyN&hbFJK2+7bPg$dK^)pL?Vo_TT57C%**sn;&L^Kg|w*Kmu4aoc?&z`A;Wa_2%u;dOj$^R`d2ROc8>o;vJE#L{y<@pl9YF$<(4%WVY?LkfM z%KxvovjD3)i}v=RrKD53JC*KIQo1_?q(NyxQc6JSlgL*YA)GjfQz z_s+sDLPD?C4Nt@Gp7Wr3*nz#oy{!qqXb1>OJulX>xXDB2-!icnj0# zfV0&gitYiMAJiQ(@3#O=-B_u|m8W66mJ^e#3{bG%p9o*(AAO8F(8Er(M#+0`<1yDm zG+i4aI<@E|P<5#F#NM}bPIaI^M%+=5o^Ac>VNoeKmKfg-z`x#vO+b-o^_5)CXkqah zJZsPc=hzIEJ9kXB+QK(X$znXE7?yEgIbm zl%{d^s@BX>be^*!|A^}ttA3ltBR3~^pG=Bw_8k8^-rF7}CCx*wI>jm;XCE{yF(cXV zSKgjhSC46wD(w5i_!#r4eN5`f4c5}Y*16Rr7PZtj{OXLtH4AqZa|eaFL4}fyQ_Pmk ztfx*l)9EzYWEa5@BXy@rwq-HL!-ZGch?sDMGERiyGy;tZ$B3| zsF9<4iOuaVqvN?t1)>W+mV?@K6Wa=e!G%!Z5JOhX|eag9@WDAykeNowP<;Kf) z=kJ)sYPdb+duCaX@;q9BL>8hnqN>hc!?p2U%AFk>)7sp?ozggdUHkFx_HOp$P<%AF z>@$|S(5*QmZ(u_*0vq?hC*tXikN=R95LZhz)E-s6g<_>H>9(s|4{s=m4CgW$GeD_JTE8VZBW zqgJ!7j~D<7bV;hWLTds=^Z>D=XZV;di}f0dDlMvlv(+q2Yis(H2t#rrVzFI*GAz6a zrMmDz{uPO2Tp{xOpQtm2U}y&9gxI{9$iu>EY|>EB$~>&Fr>S?zrY$J4?LQiG31v!C z;eL+gmCp;m!_Qzt0j9ycg%AG{JM&EfL?xz9>#S1RzCi86qyQt|0A+JF;f&io`$g74 zcha6lua>E*)gzLu>Ii&VHVNqcp{cvn2u!nZORU7cnCGg;&SGVRg!I+zNXIxFPLhvAnIoyoi(Xw22L{u)icT zw|#&phS7)hbIKq$C~n++6f}YoqicneGgF#^sTj`rl*e8bVjXn=t3PuN{forYAlUez zW?l%FG2>BnS)~KpqtDKFnYF<6tKcLGKHkbHR5RrcvYp${e%%pNJumXIH!%|N4r+b5 z(L5$$S~Lf^m3f{JWRF>M4cj4A+lxDp@znKT(8Xyj&}886#>P~}RAsuU85B-CI*Y?T zEwRg@3z|3K@cF0rMq41Vjx~()FQeu}KD>oj_tFGJLJy7A4uCJLEYv7AA=00%Y zl8LKBmqWJ8?&`N&*vY+yoA|_MvXUl2sTd+{#Zld!7#y=Y(%qN+6u;Cs);V^N(NUVC;iC;8($GIDN9WIKBaWyoW7`fA`Gq=eplX1y2RPzb>~>{}r@mosPHWAR92 zZ2@PTz2;*QTaZ)e#D=+39#BSWQNK*%jn$Y_F5be?loEwGzdO!e^-8zD`*h4>yRC(4 zY59Do`R@;P*Q6=WtVGziE!fhn7pXr;A}c$vBi@s&nWGu>4x+|hh;3pfmq~9S_`0GD zz`@*)3*#?%aY|@0dvJ2c{2?2;PT0Fw#6l&B9o~4^_p6mPZ(X= z7Rz4E9n0Gz9@)Dr^*L!GjIddQmu7Zq25#|wn%t3Iw{8iP;ti~Yq*9Rwh%cO|WVc~s` z&eU=>kMX0%(X2msG6$C4v*GZyTm4E;T?H@880gW2h4+T}jBzirsm;b;PfIpIGKWkl zB5Mdr?z4FB6W&1j7e{GoPZAR27ff|XC{S{}KTsO*FcF(&q~RPe$60?GXy4(Ruc0i9s(<5}M|RAytXI2B9l{7XN$;4}UKg}T=_|vs3bU7YHkcq7!_V-emfRIm z%wyk>R7cumDD7JOXGpyd0X>^{hF|x6IdV2ycRlSFF{%jQj*L-``2l+U_^Q!^e zA7Qfpe2?j8f{VZAKv!4G8!>WL6HLhMGp`PBQwFrK`NQn{jlg82Aif-eWl=&C?jXBg zy!ye^+(a&Xi!Y7?QYdNk{R5W=WT6YCjGuSTu-e6I?bBsxx(Eg6JiLj=B}^bv`IMGD zPz5+s@$`g+B;K-!1vEef9Un9|W+C+}=2Jbao`>cfAkV_EY{bw+v8cwst(PM73*$YEhx53z*3;gE(tClFA+f4QkGB}um?=fk z1SgE^x_j`x3s?}BM1;muhzHI&EWOR=Erc+ch@OC-vp^!1WDG_c7Z~z_1hcg=4$v;h zWZj6)B*x#D_KIG8Lf&fWfCJ}l*_V`k(jUytyfz;Ew(4Pf_LfiI)GGt>JPnO7yZmz0 z7+P>X!Qm&tJE_x|8hKTjMrb|5EynkpV{e63J!yF^H9zxqXW7<&&cD7}ypx-!SGw-h zabC;Udo4Sp?_LpB>?&Q3u&^^3^yf``j%Zh}<)uEGWA>SodZK`yGfBMWd%JB5i3Q>- zM%^5V7>8Y%`$?Va_ageMn9;?bxtA6l1eS#JCn!x6mbs^Vr$RZ~&#oUjb+v2?$k;9=BK zvYpCqkHEME*%M*lH@BP;PBs;*g3z%zVO}EKM6RSLIpxRTW7H4n2u^NAP2`NL38mQh z;yy#7({?O)sJA&hfu(M$v3T{-;Uf`#ERr17EgTjkAz9iTH_{iDYDGe#W}<84>RXh^ z9$=-e=8S?Z4Ec6A^m&@<>iL+1^>C4Jkvo!;*0a0qwZtM7UxLGHV!}!TrAsE(S0{|e z;$KsH!llBcRu*!SZyUndn=HMOdvEsjs|qm^4h_#Y2F1efAXfwtfy*ZJ&RmBB;P&c1 z3;^(BWBs3Q^LIRKDSaUfgA#G|DqiK2y^w{Fw%B!K5tc!0vmX#Be zrX7K`FqfFlMFdD-da~EgOVQ{*YZ2B&j?WeLv7ru8yO)Fy$AylJ0C$?Ao};)F%H#}J zQ1nQDFe^67rQ{yZ1`<3K`4dfOx7$bbRE-s$Ro$+yI@X!`>I=aRgsZ;mEBP4NKQXPS zktm2PeNxe5SwJl`9>qbiV&-VgC>T0c;CLE+$d5~Zv z)MGcmMlg%kv!TRFe{`2?JQC+=QNRiDZOr4oXcG!v=I1Gm?#bPbi3Z;Tw)*K~Q0q2( zM%?(mD-zL~o*tt%KshHd11?ogv{NDQ+zgmbO`b3W2q*e$EEIAjsap3RqEhE0Qrs_QYw-NT|u_1p94dbv#z zBLyA<)8dGoyqM=hXIGA|oAHEZy_L(4gj<8anZ3>ODdEW~7uvXc=~m1Rp@T0tMzH(z z`!kSO2o+#Qzh-UHLI|8hStI_~#Q(?1J}yt9E^Y7qweF4j<3<8d$L8CM#@_7E<_cb% z{m21d%hEDtIwJ?z0A3jp!|~$9X~?;=k8*VFgyR&lxXva|iqmmwSqXX}Z0n<#+Va#HVRu1IZ-Kp>@VYM^PqUz~=`eke-VHCwsc~!Q z1I02ef@OmZ7X^QCimGzTBf~7JR64BHS*_^sE)_I@A|7laFy4|PMBKivZ5q*}8V-kC zq)RY94v-EXDhc-RX*jV@CmQyL!)8&u^;k8+;$mr3vq`W#VMYbBzJkt#-p>9Bd_LF1NRFQtd=d zDUNQ!B^q5t%3H7dW;Q(@J1|f9KLcKFi86?(KaG}p{rrHDc85N#` zW3ai$27SjmpL+NK`@F)EBD9_#`}e?jzaJ4gzuD(q-Ll)H zE(p8H>3Xbo!-J0DgAqwB5~LK}1^H!&O=l-E6?oizL;aivM1r1aCj%>aIt)z(JAy+} zEH?08@gBs!R)T)fpw>c$DA?8jY3$j=D~^LA503+d(rn_m=#omz!&If4!jgWV2#E92 z9Kh(&Cx-3ndq&vC(kja0r+}9zq2i@RwP|Ik+CMsC$0k02O_ND3cC^< z2+-=XGE`$==H<|VuQ?*rGs_4O_#$aUrxb$u2++8idGQ4c$54CcsRBe76)W?z=KV^| z^KEmuu7Pm}()!aXEM$Awom1HHv9p5&W zgQJT9QJa6DaPKvlqPNcjUV>aa{6LzL3=52|dyn$hZ$t0g4W@90d{$OJes{jDbllNB zA;MxtL2B050OwBSql`t|kf0%2@LI1rw!X<~En{Bo0OW@cS+civ`e%npc+ApCVY*n4 zF&&8G`c2<0Zmp!1;ah&r;H^KJHI7I12+`hear2~AIDUvX5f9JDEX*{#~;3&XUvuRrZY+v7%sZ{ z{a%h_MOX6p)1(>nDw(0{VA=aO_hZPTQoGLJ#s|J!)Xa#-$6{VR?-65_O~2r$>|^cb+}jm^!n3H7eRofhf?Lx66{M zCf&^RMj-7Q*r~TxI<88X{2f-S)d`l_Qx3w~65qC1{~`sIATUwCwdm3#L(fLf+EHp# zT+JS-(mFnVI**=o9MtlA9e7#_m_|yWQHr|pZ-RZJ-Vk%$(R}G^41tU$u`)_7;xGD+ zpOZbPu`{aC!H;B5T){Wz1R3$=0#d4A?jy~x5fOIDCevV<^v>R}FZQbQ(jNEqn(SI# zSp_R0s9_!h9s~H;0mR3SZq8gBtXV?6CD0@~2)V1YlEKOEzv9|Q8SI;Ym7)=N!)mi5 zRNxll7Q2UhNc&1btT@W^$Y)P84d2{f*;!db-6uAaw4BEAC|w!j{T2gJWo$(PPkT^C zLLe)wcoY?Ia)qo*l7O}RWllN?ZyrF;SS0?anA*c*|ByvDXRQ)8in$lT$_FQMBzGHG zrz|Ula}cF_)}bzw!%|JmK zCVg}ey`~fW8y#65=b?_Zb(|9`L-3Bzo92?uBYbtl7p>Khi$^AncEoON$m_T_!bDH*>~~awJGbiWbbJ%$Gp3sx6oqmKz(;D&%OEehiz{ zL;xjOz&3O&{!xFrYU82B?Qm7=%+CWpg+lkmm+bID1niJwjtQb^RFfpyV(!n~K`e%G z6^GCzKn|VHR6>d}aa(Ej*%(_Cd8_x%VU1wuNGZeRn7HmC@0g-!F1yxFi}ltBU7VEs6teb8GnkXSM(^> zRxgM!qWyqCLVtVLMIQe%Z*>e%*+7#wqK^x;f}Equ8-{bNUBF2oMDBCRcu<#T-S^WT z+8*wT<%u#)1Z&R4a7S#DL5eSVo7}r)o+tAHuLB0#pVRIB*d^o^c<-$)(k+ z*dSQVF4fO1J3I2?y1H?DFE`J2e>rXj93s%d(>DnPI%?{(ZykkqIPwnBzd%DR$~KTw zP@JECB}?__R&2J~e;HAsF0z*0WEj0dcG`I; zf|RO2K}#0L8uF!%diXm7#-!AnhtqDJTAvqntKeJeCB$9BTkqp|FL%?6Am1rVp?kT% zI6T=;%9=|RzO=#AH^e*-8Subpzb5ytg^~Gp!&NZ9HI`QI%s^>YBDf$_4zRbr!0${+ z%}Rz(&M!#DN(Z1mCl@ppG;YEgsN8WVL|WW@`ilE)3j|RjWQ>_qt0~qeRjDz>CR>;& zu3K9fBGQERqTL=N`pe=@Xg%%egYkj!d*V}H{SmUf=za2VJ2{nDn>c8MrpWcwRs0`Q ziR_Wu#O@MptO<=^itZ=GcR5EORn~&NAmzJPIwUiRrVb+(iI~f8R?C>TyC$sLrT323 ze>m16DZ^rR-7#TLV5HXqjnWds%=V$=z^cc=!^}#R+m-{NCoG-$u+zh~JR4tDaXuE4 zvBPSoLvFDzIh=r7q?3u0WT<;Ol#{lSa!fB*@3fBDb?!*uVVX~knqx6qRxcAottc71 zRnHlth3|AGa!Z8O@v`x>ViqEW_&U; zU@OK~J;ePecLEv!*aL1v{)>E+muEGXPx$}pr{aNnpKQp_`5A$N|BckLx~g0)twoIj z{0L@6P-er)d$I`PL<6W6r4dvSY4g~gz-bM-#ab)l({J*b8M1dP9C_q3T^uQ66@|X_ z8wv;xFjAwThZEA!jIMO9z*3?_z<#A3a6uKyOob0X8()E)We(GoLxoQ_3OG*a3-RgT zMG4v!8u=P3t1~zYuAZ;{itxT%52eH&ads0y=Uqhw(`V>!Y^STnRi^Q>IN)ONfN34X z{Bd0*ipW|d1ByjEf*#zFLJ`S|@Ci~llxqLr&yFpfEk=MqZsrN@4w1`B4v z7KSn*%_~p>X;1LA_jUui5mKT0Qpa2*VcM&rFEmGm){3gc17`=j_>dYD>;nP zBwMt^ZpY-8=R^=3i)6!MOhT{6sFNCt=cJiF+jPp$Q*Ss9HML3737D_39M6Vtp+?%x z-=*kd;`U;X@-BIFjAuf%VlV=gH&SgX?I=ycdyZf$te`wsczDvkwN<^8nDQW|sJC-lOgO_FPaCZSML}4A6>_Ot zvDaW60_Kg^R$Q|&|5juZi#wEoc2^7`%t-1`B_0LIe)dQ!u6SSy1_XV^QS(S?+Pcm1 zN|r-hMW4xd;UF(HtjNH6JvTHSFI4O`-FUj8%h-FQ_$`N_?6)+BN7_dp9uE*k{LZRS5gqWdC7{?~NppvNK-X575 zWk}Rz-?QRgPpmW9eIe6{dRI``;0r~-9F#6&F__;MdlLvuXa5v__+!`zJ$Bi{)*2V} zzWhqzo#Sr=SfWOO_0|+Km7VUkKmOI|`*gxqb*KBla$6^%^NlU4Gm&T@0YVfnt_0g` zUcaljO{0J@I2c1DDNcX5>q>JtB6ZK|MNWxkin(m+n|~zjQ)=ETf?$qEJKKJ*s?t;!PXLSnrZ^ zW>3YKVTHwa*-gmF%>I1bR=cW*+f$?v4&0v@8upDKCPS%dkO!cq>LAq?FgE}}SoOin zkriEE!9&aAJ|2o3HH)5>Q7kRT3)Mt;Rac#A@8ov|6EHU3w_DZgRdvlT98=tbg_lDK zM)G9JHw%7ja`>Gh@f)^I;#lsx%6#oxrFxbxa4VM8-xt;e_E=T~H>BIQV-c58&Qw$+ zj7vLCQx#4kmduDMs~Egbf7*U)W3y}tEI@WsHSl0e$J;Sv>|VC zf0?h1U(10=loX52R3@lpZ|<&m=9ae1K(#$C*LS?IhSURM}j%oA`24 zU2W%%n)YTbgt!;%^6zYhUWQr5 zPi=EJ`K2zj;EwvVJMB&TfDL7t9BueyQl5dR0mu}&saxBQIvxR!6a;}0P7=Sry#^AL zmJmMqcv1k_ck6)Kw%sfib_NljnbnHSpv030(V?eSzV1=f*!us#rSCveXh8~ zQ)2%Z_d3q?qR-xubkT}Y$Z>ckF9nvM6w1TWq~Iby!PR>T`PqdPF%EuvT-Q}FH*6(p zrhv>5ETKX)j7lOtB(LqQ`03U}hac}7ALJMW9c&m*OSo1Bxbi?Wk_cG!eUjPSky$5c zwU^1L4gG>iuX{dyBC{y^{LB=+kVS=MK&?}Sn1c+lJtYTnEqzPJ{j5? zb`hIv9nxWv)zk=cETPIivU|@o7`*(a(#_Oqn>1G=0SaxHI8yJP3^#}@$_?=`7wlu~ zhxD*WrM4+pFfx7;MSQq28PFg;t0nCOOQ>f*@VF(bscyV|vwdgkHeDQkwDtN9k&wfH zWl|V}Nf4qVd~mcOm%cHMe1ECu!LZRu+;}pyJ%;dN%k#MR8gHcB+}AT6kn+`@Q)i|8B{J!pO zbxi-JyTH?@m8yp-W2cN+GzTBw-(wWL_lEx4o0-oh^Vjo`q|xerFP+G&~&YZDrE@9Q*rvRKo?q_`jd`E(5cTvtwT z)hK)cHZVq@T#C%^hh>}x`~4Y72Yl-dKED6nIHJw7 zTPci4PEHn6Xk#vDQPWKw`f0CbL16fCpN_Q))H`)3@u2MTPo1wbSfHp{8~QW4$;+u( zu$3Vhu}t4u4Cet)6vmZ!RU`FKH-(P%?QB?eA(~_!2W)J|4zqTuxH)TwXMUYJZ44!P zG)*Gsp#q0+u#KnB_@MK4kp%6B$LTP=qyrVCv$(z$A9mSmqWI}w%P#W7jlm4&4HPpI zy98hh5P#K~6(SIgCY;5`N=I_cl6J3k+4m5L99UVKAy<5vC@wmBdn6U%Fhqy2ZP;a? zGNg|G-FKE_F!hIT)@zudEd?Haw_51LXOeejIX-1d3=$A&>-p%hPCF$L6ESx77L2bF zaiIF>OWP=%<7?g9+zM|x;EKL;v&MJ88Iyi<7aMp&-SZ-DE*hoa%mi}c$paMKw6rc9 zto_dxtr&>|ctzvj@f$W3_s0mT&Atvo7b~<*S0ZtbF;A=L_<>_o%seaD0ns@t2kvq{ zT#3cj0Ui)|!vDy?@Y``e=M4-rM)YUwkFv&(6H+&%PyBd80?Da9_Un4SJm$G-%_Wid ze3^OB&`-!vA{dJo*#r;kx2P%>Bqv_KT+&14{SevbP-pjwFV(LK$vhZ&fn|}|^NCN3 zNYiNRi@=a+nMyP!!Z5$8TZbKx*uHF^;d3Uza4BIW8vHt;K47T#CxFkgtS|`NdzsW% z;sJ%fHaUZ4z9}*Bbj!v+FQHO$X0j;$%{pc zH^qL`X%;R?GJsj!XKKjEs3VLj0`|kCW|QJjR}>UHIQs1m>-bg9eY34L1|Q?t>?G=> z>jM!eI$03213DoJC^c7i83i%K9%P{?K5X*hthFWkL`C!h!A%7tUIEq=@_WkRj_Gp# z8a-8Ri_>VaZ4p&d!(=p-{axA2++o3xJ(d9EaMLmIF364fW~N6r%MW)Ejzt#kYKfpE zEnB-!o@y;oZz#T0_JuMn9wJ#{mE|IsMLnLlXBJg6J;j8`gR^5IZ)sO9^up6WZ8Qu) zmh6!63Bj9QrjK(jwd58}(|u)Qan)OJhF}}@&akqOCE0-`mQ?pGi#F>*d>8J>jyXgc zX}hz!d&nP)w|mMo14agpcbyE`z!nIPYrDV<*4!LVFjU19o|>KFAzDczm(tlK`cHiH z#x+chsztX`Qt8=|_n?$H!*zUbq_cBVE<`mnzWG|KUABli}*?+5Nn90BWU%%1`})Mn;f2u)jCq{INs_{i^uq zRxaE@yyl)FsPXGE{GOZl21--?!;g4_`F=q;JFevWJ*NZ!e#mb(!H}DoId=2U!0V!!Iob zP?)Rv5u|oW$#?h*>{da3e;)3xf;3zbTNb9WvI(p z_s*gA|NlWEq5h>q z3@}dw@eSgDCKdqo$kl{mpa^onTLm{(FMlHZ6b1ri_@ixHNDuQ*mTxPhK zpaYZvmj1tDxVBwfO^g8wLjXLhzOhRAl_mq!8CUaMfZFfBY5NzlUVw7^Xc!k$27q!P zu-vd8E^u61F+YGVO0RkA%f7iN9Suq$!*heaxhmXz8RW8N^f}7M{}$xh3c4y8ea-_^ zG2*>R*Idv_zU-FE63yorzCd~68+)36Y9IWyH2zzcTvSCqX8|U!;r|b4uFi^n)XQas z<8uskf&UERT9^EgjJ&8=e9i&@U<>{SG(Yu=L0icWh>J48pb%6-{~5&Jy5yoPFDQ+e z@P9ya_YX<1%PzSn!3zp8^WQ;S>yqpAcF%d9i~I*JxmJDmvWG6J-kuWy0Kq^N(HrYp zE=a&$X1FXodrlD|_FpkvTS-^dU(ZnhfT;U74|BD1`@wKg!xfZ4>A`=+aIHhG3bBI1 z;EVrzn7@%_1#KEvwG2UxtH}Ig<3HteE}S3yl7_kP>i?u{2ugTW)DV>L%fBT&mpHs^ z?4l$gsIfP|bCrMiwElF*AI8oF3PCMirzUuAQyCa<`L8VgI-B_A{9mv9owgt-)eom% z)D}Ev0sub#TdKcR8U(d{otoacbrbo2>5)HUP=ER3&);c5U;m{_1j=(&Tko6(09gG^ zo@+EOu2VhxAC&e$S+CRBJEsj+_&wiU)e!i5R1g)nYrT3^aqpZH0H6UXYyYcu|7UGp zQrEi<^WsJ9YZkvWyd@bE|3V!EwwyMAB#q&s~zZ-~jE)}_!@~WQS zIU_Jhn%a#~g2rS0y*vL_-4FChx~l63%3Sd;m@i6e{NYeggI5KrKn-dG({KFKA?BjN zYld!6^VezkoCCbmzajG=11+fa>!eH0tqTHE(fsCzzc_w^n!c)Oac&p@NCoO;|E}qa zqavv7>(mR*t=}{IZQEA|I#BahZ-Ad02MT;x-jw-^BOEBf)oZ1o1PQjkO>ku}0=0hi zt{A9wF^8M64l=@k8ow^I{@i@H+ix2O89PAjUX8duw+g&6_xy(J{t|%&wS6@h7u2@0 e*A3bR9SUS6p@6pmfeE02-|W=DbVj~Ee*1rA5$4VS literal 0 HcmV?d00001 diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index 4a7e3c32..8c778061 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -152,7 +152,8 @@ tcl::namespace::eval textblock { hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} } proc use_hash {args} { - set argd [punk::args::get_by_id ::textblock::use_hash $args] + #set argd [punk::args::get_by_id ::textblock::use_hash $args] + set argd [punk::args::parse $args withid ::textblock::use_hash] variable use_hash if {![dict exists $argd received hash_algorithm]} { return $use_hash @@ -4143,7 +4144,8 @@ tcl::namespace::eval textblock { proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + #set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opts [dict get [punk::args::parse $args withid ::textblock::periodic] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -7913,7 +7915,8 @@ tcl::namespace::eval textblock { #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { #as frame is called a lot within table building - checking args can have a *big* impact on final performance. - set argd [punk::args::get_by_id ::textblock::frame $args] + #set argd [punk::args::get_by_id ::textblock::frame $args] + set argd [punk::args::parse $args withid ::textblock::frame] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8650,7 +8653,7 @@ tcl::namespace::eval textblock { size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id ::textblock::gcross $args] + set argd [punk::args::parse $args withid ::textblock::gcross] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/bootsupport/modules/tomlish-1.1.5.tm b/src/bootsupport/modules/tomlish-1.1.5.tm new file mode 100644 index 00000000..7ff93c3e --- /dev/null +++ b/src/bootsupport/modules/tomlish-1.1.5.tm @@ -0,0 +1,6973 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# 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 tomlish 1.1.5 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.5] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #default interp recursionlimit of 1000 is insufficient to pass 1000 deep nested structures as in certain toml tests. + #e.g https://github.com/iarna/toml-spec-tests/tree/latest/values + #1000 seems deep for a 'configuration' format - but toml sometimes used for other serialisation purposes. + #todo - review + set existing_recursionlimit [interp recursionlimit {}] + if {$existing_recursionlimit < 5000} { + interp recursionlimit {} 5000 + } + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + #This reordering idea is complicated by the nature of tablearrays - especially as a table header references last tablearrayname, + # and duplicate table headers are allowed in that context. + #e.g + #[[fruits]] + # name="apple" + # [fruits.metadata] + # id=1 + # + #[unrelated1] + # + #[[fruits]] + # name="pear" + # + #[unrelated2] + # silly="ordering" + # + #[fruits.metadata] + #id=2 + #The TABLEARRAY record can't be completely selfcontained on the default parsing mechanism - because it is legal (though not recommended) to have unrelated tables in between. + #If we were to 'insert' later related records (such as the 2nd [fruits.metadata] above) into the TABLEARRAY structure - then, even though it might produce 'nicer' toml, + # we would lose roundtripability toml->tomlish->toml + # ----------------------------------------------------- + #REVIEW + #todo - some sort of 'normalize'/'grouping' function on tomlish that at least makes records self-contained, and perhaps then (optionally) reorders resulting records sensibly. + #such a function on the tomlish may work - although it would be unwise to duplicate the validation aspects of to_dict + #The most practical way might be to use to_dict followed by from_dict - but that would lose comment info and formatting. + #In the above example - The decision by the toml author to put [unrelated1] between related tablearrays should be respected, + #but the positioning of [unrelated2] between a tablearray and one of its contained tables is suspect. + #Both [fruits.metadata] table records should theoretically be added as children to their corresponding [[fruits]] tablearray record in the tomlish. (just as their name keys are) + # ----------------------------------------------------- + + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE TABLEARRAY WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #removed - ANONTABLE + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + #todo - configurable - allow empty string for 'unlimited' + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + #find the value (or 2 values if space separated datetime - and stitch back into one) + # 3 is the earliest index at which the value could occur (depending on whitespace) + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keys are lists {parenttable subtable etc} corresponding to parenttable.subtable.etc + } + set sublist [lrange $keyval_element 2 end] + + set values [list] + set value_posns [list] + set posn 0 + foreach sub $sublist { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + lappend values $sub + lappend value_posns $posn + } + default {} + } + incr posn + } + switch -- [llength $values] { + 0 { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + 1 { + lassign [lindex $values 0] type value + } + 2 { + #validate than exactly single space was between the two values + lassign $value_posns p1 p2 + if {$p2 != $p1 +2} { + #sanity check + #can probably only get here through manual manipulation of the tomlish list to an unprocessable form + error "tomlish KEY appears to have more than one part - but not separated by whitespace - invalid '$keyval_element'" + } + set between_token [lindex $sublist $p1+1] + if {[lindex $between_token 1] ne " "} { + error "tomlish KEY in 2 parts is not separated by a single space - cannot consider for datetime '$keyval_element'" + } + lassign [lindex $values 0] type_d1 value_d1 + lassign [lindex $values 1] type_d2 value_d2 + if {$type_d1 ne "DATETIME" || $type_d2 ne "DATETIME"} { + error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" + } + set type DATETIME + set value "${value_d1}T${value_d2}" + } + default { + error "tomlish Found multiple value elements in KEY, expected one. (or 2 for space-separated datetime) '$keyval_element'" + } + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [ list [lindex $values 0] ]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole [lindex $values 0] (type val) - not just the $value! + set prev_tablenames_info $tablenames_info + set tablenames_info [dict create] + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + set tablenames_info $prev_tablenames_info + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + package require dictn + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + + #Declaring, Creating, and Defining Tables + #https://github.com/toml-lang/toml/issues/795 + #(update - only Creating and Defining are relevant terminology) + + #review + #tablenames_info keys type created, defined, createdby, definedby, closedby ??? review keys + # [tname] = header_table [[tname]] = header_tablearray + + #consider the following 2 which are legal: + #[table] #'table' created, defined=open type header_table + #x.y = 3 + #[table.x.z] #'table' defined=closed closedby={header_table table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k= 22 + # #'table.x.z' defined=closed closedby={eof eof} + + #equivalent datastructure + + #[table] #'table' created, defined=open definedby={header_table table} + #[table.x] #'table' defined=closed closedby={header_table table.x}, 'table.x' created defined=open definedby={header_table table.x} + #y = 3 + #[table.x.z] #'table.x' defined=closed closedby={header_table table.x.z}, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k=22 + + #illegal + #[table] #'table' created and defined=open + #x.y = 3 #'table.x' created first keyval pair defined=open definedby={keyval x.y = 3} + #[table.x.y.z] #'table' defined=closed, 'table.x' closed because parent 'table' closed?, 'table.x.y' cannot be created + #k = 22 + # + ## - we would fail on encountering table.x.y because only table and table.x are effectively tables - but that table.x is closed should be detected (?) + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + + + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keyed on tablepath each of which is a list such as {config subgroup etc} (corresponding to config.subgroup.etc) + } + + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [tomlish::to_dict::get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #tleaf -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set tleaf [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set tleaf [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $tleaf]} { + error "Duplicate key '$table_hierarchy $tleaf'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + dictn incr tablenames_info [list $table_hierarchy seencount] + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + set t [list {*}$table_hierarchy $tleaf] + dictn incr tablenames_info [list $t seencount] + dictn set tablenames_info [list $t closed] 1 + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } + + } + TABLEARRAY { + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + + set NEST_DICT [dict create] ;#first blush attempt at referencing supertable tablearrays + set tablearrayname [lindex $item 1] + log::debug "---> to_dict processing item TABLENAME (name: $tablearrayname): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablearrayname true] ;#true to normalize + #we expect repeated tablearray entries - each adding a sub-object to the value, which is an array/list. + #tablearrayname is likely to appear multiple times - so unlike a TABLE we don't check for 'defined' for the full name as an indicator of a problem + set supertable [list] + ############## + # [[a.b.c.d]] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of tablearray name $tablearrayname already has data but doesn't appear to be a table - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_supertable_keycollision + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } else { + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #REVIEW!! + # what happens with from_toml {[[a.b.c]]} {[[a]]} ??? + dictn set tablenames_info [list $supertable type] header_table ;#how do we know it's not going to be a tablearray? + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } else { + #supertable has already been created - and maybe defined - but even if defined we can add subtables unless it is of type itable + #but if it's a tablearray - we need to point to the most 'recently defined table element of the array' + #(another way of saying last member of that array)?? + set supertype [dictn get $tablenames_info [list $supertable type]] + if {$supertype eq "header_tablearray"} { + puts stdout "todict!!! TABLEARRAY nesting required for supertable [join $supertable .]" + puts stdout "todict!!! todo.." + #how to do multilevel nesting?? + set EXISTING_SUPERARRAY_ELEMENTS [dict get $datastructure {*}$supertable value] + dict set NEST_DICT $supertable $EXISTING_SUPERARRAY_ELEMENTS + puts stdout "todict!!! supertable '[join $supertable .]' elements $EXISTING_SUPERARRAY_ELEMENTS" + } + } + } + # + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + #first encounter of this tablearrayname + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[[a]]} + set msg "Cannot create tablearray name $tablearrayname. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_direct_keycollision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no collision - we can create the tablearray and the array in the datastructure + dictn set tablenames_info [list $norm_segments type] header_tablearray + dict set datastructure {*}$norm_segments [list type ARRAY value {}] + set ARRAY_ELEMENTS [list] + } else { + #we have a table - but is it a tablearray? + set ttype [dictn get $tablenames_info [list $norm_segments type]] + #use a tabletype_unknown type for previous 'created' only tables? + if {$ttype ne "header_tablearray"} { + set msg "tablearray name $tablearrayname already appears to be already created as a table not a tablearray - invalid?" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #add to array + #error "add_to_array not implemented" + #{type ARRAY value } + set ARRAY_ELEMENTS [dict get $datastructure {*}$norm_segments value] + } + + + set object [dict create] ;#array context equivalent of 'datastructure' + set objectnames_info [dict create] ;#array contex equivalent of tablenames_info + + #add to ARRAY_ELEMENTS and write back in to datastructure. + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #MAINTENANCE: temp copy from TABLE + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + #set supertable $norm_segments + set supertable [list] ;#disconnect from main structure - each array element is a new context for key paths! + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey '$dottedkeyname' kv: $keyval_dict" + #dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #wrong + #TODO!!!!!!!!!!!!! + #lappend ARRAY_ELEMENTS [list $dottedkeyname $keyval_dict] + dict set object $dottedkeyname $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + TABLE { + #we should be able to process tablearray subtables either as part of the tablearray record, or independently. + #(or even a mixture of both, although that is somewhat an edge case) + #[[fruit]] + #x=1 + # [fruit.metadata] + # [fruit.otherdata] + + #when processing a dict destined for the above - the tomlish generator (e.g from_dict) + #should create as 1 or 3 records (but could create 2 records if there was an unrelated table in between the subtables) + #choices: all in tablearray record, tablearray + 1 or 2 table records. + # + #We are going the other way here - so we just need to realize the list of tables 'belonging' to this tablearray might not be complete. + # + #the subtable names must be prefixed with the tablearray - we should validate that for any contained TABLE records + + } + default { + error "Sub element of type '$type' not understood in tablearray context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #todo? + ##end of TABLE record - equivalent of EOF or next header - close off the dottedtables + #foreach dtablepath $dottedtables_defined { + # dictn set tablename_info [list $dtablepath defined] closed + #} + + if {[dict size $NEST_DICT]} { + puts "reintegrate?? $NEST_DICT" + #todo - more - what if multiple in hierarchy? + dict for {superpath existing_elements} $NEST_DICT { + #objects stored directly as dicts in ARRAY value + set lastd [lindex $existing_elements end] + #insufficient.. + #dict set lastd [lindex $norm_segments end] [list type ITABLE value $object] + dict set lastd [lindex $norm_segments end] $object + #set lastd [dict merge $lastd $object] + lset existing_elements end $lastd + dict set datastructure {*}$superpath [list type ARRAY value $existing_elements] + } + } else { + #lappend ARRAY_ELEMENTS [list type ITABLE value $object] + lappend ARRAY_ELEMENTS $object + dict set datastructure {*}$norm_segments [list type ARRAY value $ARRAY_ELEMENTS] + } + } + TABLE { + set tablename [lindex $item 1] + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + #As our TABLE record contains all it's child DOTTEDKEY records - this should be equivalent to setting them as defined at EOF or next header. + + log::debug "---> to_dict processing item TABLE (name: $tablename): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablename true] ;#true to normalize + + set T_DEFINED [dictn getdef $tablenames_info [list $norm_segments defined] NULL] + if {$T_DEFINED ne "NULL"} { + #our tablename e.g [a.b.c.d] declares a space to 'define' subkeys - but there has already been a definition space for this path + set msg "Table name $tablename has already been directly defined in the toml data. Invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + + + set name_segments [::tomlish::to_dict::tablename_split $tablename 0] ;#unnormalized e.g ['a'."b".c.d] -> 'a' "b" c d + #results of tablename_split 0 are 'raw' - ie some segments may be enclosed in single or double quotes. + + + set supertable [list] + ############## + # [a.b.c.d] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of table name $tablename already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] header_table + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } else { + #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable + + } + } + #table [a.b.c.d] hasn't been defined - but may have been 'created' already by a longer tablename + # - or may have existing data from a keyval + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[a]} + set msg "Cannot create table name $tablename. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablename_keyval_collision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no data or previously created table + dictn set tablenames_info [list $norm_segments type] header_table + + #We are 'defining' this table's keys and values here (even if empty) + dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here + } + dictn set tablenames_info [list $norm_segments defined] open + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> normalized table key hierarchy : $norm_segments" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + set supertable $norm_segments + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey $dottedkeyname kv: $keyval_dict" + dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #end of TABLE record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dictn set tablename_info [list $dtablepath defined] closed + } + + + #review??? + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + #take a raw string and classify: result is a 2 element list comprised of KEY|SQKEY|DQKEY and the value being the appropriate inner string + proc _from_dict_classify_key {rawval} { + if {![::tomlish::utils::is_barekey $rawval]} { + #requires quoting + # + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + # + #we'll use a basic mechanisms for now to determine the type of quoting + # - whether it has any single quotes or not. + # (can't go in an SQKEY) + # - whether it has any chars that require quoting when in a Bstring + # (if so - then its visual representation might be unsuitable for a key in a toml text file, so escape and put in DQKEY instead of literal SQKEY) + #todo - more? + #REVIEW - the backslash might often be in things like a regex or windows path - which is often better expressed in a literal SQKEY + # from literal examples: + # 'c:\Users\nodejs\templates' + # '<\i\c*\s*>' + #If these are in *keys* our basic test will express these as: + # "c:\\Users\\nodejs\\templates" + # "<\\i\\c*\\s*>" + # This still works - but a smarter test might determine when SQKEY is the better form? + #when coming from external systems - can we even know if the value was already escaped? REVIEW + #Probably when coming from json - we know it's already escaped - and so we build our dict converting keys to unescaped + #TODO - clarify in documentation that keys resulting from to_dict are in 'normalized' (unescaped) form + # + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + set k_escaped [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + if {[string length $k_escaped] != [string length $rawval]} { + #escaping made a difference + set has_escape_requirement 1 + } else { + set has_escape_requirement 0 + } + if {[string first ' $rawval] >=0 || $has_escape_requirement} { + #basic string + # (any ANSI SGR sequence will end up here in escaped form ) + return [list DQKEY $k_escaped] + } else { + #literal string + return [list SQKEY $rawval] + } + } else { + return [list KEY $rawval] + } + } + + #the quoting implies the necessary escaping for DQKEYs + proc _from_dict_join_and_quote_raw_keys {rawkeylist} { + set result "" + foreach rk $rawkeylist { + lassign [_from_dict_classify_key $rk] type val + switch -- $type { + SQKEY { + append result "'$val'." + } + DQKEY { + append result "\"$val\"." + } + KEY { + append result "$val." + } + } + } + return [string range $result 0 end-1] + } + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + set K_PART [_from_dict_classify_key $k] ;#get [list SQKEY ] + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + set result [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + #(SQKEY & DQKEY do not have the enclosing quotes in their returned val) + #if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + # set VK_PART [list SQKEY $vk] + #} else { + # set VK_PART [list KEY $vk] + #} + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + #REVIEW - we could detect if value is an array of objects, + #and depending on parent context - emit a series of TABLEARRAY records instead of a DOTTEDKEY record containing an ARRAY of objects + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + + #we can't just join normalized keys - need keys with appropriate quotes and escapes + #set tname [join [list {*}$keys $vk] .] ;#WRONG + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list $K_PART] = ITABLE {NEWLINE lf} + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + lappend result TABLE $tname {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list $VK_PART] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + #review - where to make decision on + # DOTTEDKEY containing array of objs + #vs + # list of TABLEARRAY records + #At least for the top + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + error todo + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like tentative_accum_squote need to do their own append + switch -exact -- $tokenType { + tentative_accum_squote { + #should only apply within a multiliteral + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-squote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-squote-space { + } + default { + error "--- unexpected popped due to tentative_accum_squote but came from state '$prevstate' should have been trailing-squote-space" + } + } + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type single_squote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + MULTILITERAL { + #empty + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + ''''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "''"] + } + MULTILITERAL { + lappend v($parentlevel) [list LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + } + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + tentative_accum_dquote { + #should only apply within a multistring + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the trailing-dquote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-dquote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-dquote-space { + } + default { + error "--- unexpected popped due to tentative_accum_dquote but came from state '$prevstate' should have been trailing-dquote-space" + } + } + switch -- $tok { + {"} { + tomlish::parse::set_token_waiting type single_dquote value $tok complete 1 startindex [expr {$i -1}] + } + {""} { + #review - we should perhaps return double_dquote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_dquote value "" complete 1 startindex [expr {$i - 2}] + } + {"""} { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 3}] + } + {""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left dquote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {"}] + } + MULTISTRING { + #empty + lappend v($parentlevel) [list STRINGPART {"}] + } + default { + error "--- don't know how to integrate extra trailing dquote with data $v($parentlevel)" + } + } + } + {"""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 dquotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {""}] + } + MULTISTRING { + lappend v($parentlevel) [list STRINGPART {""}] + } + default { + error "--- don't know how to integrate extra trailing 2 dquotes with data $v($parentlevel)" + } + } + } + } + } + triple_dquote { + #presumably popping multistring-space + ::tomlish::log::debug "---- triple_dquote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTISTRING { + lappend merged $part + } + STRINGPART { + if {$lasttype eq "STRINGPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + CONT - WS { + lappend merged $part + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_dquote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g tentative_accum_squote does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + tentative_trigger_squote - tentative_trigger_dquote { + #### this startok will always be tentative_accum_squote/tentative_accum_dquote starting with one accumulated squote/dquote + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + single_squote { + #JMN - REVIEW + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERALPART + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + triple_dquote { + set v($nest) [list MULTISTRING] ;#container for NEWLINE,STRINGPART,CONT + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + tablename { + #note: we do not use the output of tomlish::to_dict::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names from + # a structural perspective. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$trimtable'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablearrayname: '$trimtable'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + #puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + #puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + single_dquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + dquoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + multistring-space { + lappend v($nest) [list STRINGPART {"}] + #may need to be joined on pop if there are neighbouring STRINGPARTS + } + default { + error "---- single_dquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_dquote { + #leading extra quotes - test: toml_multistring_startquote2 + switch -exact -- $prevstate { + itable-keyval-value-expected - keyval-value-expected { + puts stderr "tomlish::decode::toml double_dquote TEST" + #empty string + lappend v($nest) [list STRINGPART ""] + } + multistring-space { + #multistring-space to multistring-space + lappend v($nest) [list STRINGPART {""}] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + + } + single_squote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from tentative_accum_squote pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- single_squote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + enddquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + untyped_value { + #would be better termed unclassified_value + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + unset -nocomplain tag + if {$tok in {true false}} { + set tag BOOL + } else { + if {[::tomlish::utils::is_int $tok]} { + set tag INT + } else { + if {[string is integer -strict $tok]} { + #didn't qualify as a toml int - but still an int + #probably means is_int is limiting size and not accepting bigints (configurable?) + #or it didn't qualify due to more than 1 leading zero + #or other integer format issue such as repeated underscores + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. (looks close to being an int. Formatting or range issue?) [tomlish::parse::report_line] (no space level change)" + } else { + if {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok] || [::tomlish::utils::is_timepart $tok]} { + #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a localdate + #e.g x= 2025-01-01 02:34Z + #The to_dict validation will catch an invalid standaline timepart, or combine with leading date if applicable. + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + } + } + } + #assert either tag is set, or we errored out. + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [dict create] + dict set Bstring_control_map \b {\b} + dict set Bstring_control_map \n {\n} + dict set Bstring_control_map \r {\r} + dict set Bstring_control_map \" {\"} + dict set Bstring_control_map \x1b {\e} ;#In spec it's included in the list of 'must be escaped', as well as the 'convenience' escapes - so we make it go both ways. + dict set Bstring_control_map \\ "\\\\" + + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + #8 = \b - already in list. + #built the remainder whilst checking for entries already hardcoded above -in case more are added to the hardcoded list + for {set cdec 0} {$cdec <= 7} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + # \u007F = 127 + dict set Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + #plus \e for \x1b? + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + append buffer {"} + } + b - t - n - f - r { + append buffer [subst -nocommand -novariable "\\$c"] + } + e { + append buffer \x1b + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\$c" + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] ;#0b101 etc covered by a-f + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + #(but still allowing 0 -0 +0) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. (excludes also +++1 etc) + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + + #------------------------------------------- + #unclear if a 'digit' includes the type specifiers x b o + #we assume the 0x 0b 0o are NOT counted as digits - as underscores here would seem + #to be likely to cause interop issues with other systems + #(e.g tcl allows 0b1_1 but not 0b_11) + #Most of this structure would be unnecessary if we could rely on string::is::integer understanding underscores (9+?) + #we still need to support earlier Tcl for now though. + + #first rule out any case with more than one underscore in a row + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_0xFF + if {[string index $utest 0] eq "_"} { + return 0 + } + if {[string range $utest 0 1] in {0x 0b 0o}} { + set testnum [string range $utest 2 end] + } else { + set testnum $utest + #exclude also things like 0_x 0___b that snuck past our prefix test + if {![string is digit -strict [string map {_ ""} $testnum]]} { + return 0 + } + #assert - only digits and underscores in testnum + #still may have underscores at each end + } + #assert testnum is now the 'digits' portion of a , 0x 0b 0o number + #(+ and - already stripped) + #It may still have chars unsuitable for its type - which will be caught by the string::is::integer test below + if {[string length $testnum] != [string length [string trim $testnum _]]} { + #had non-inner underscores in 'digit' part + return 0 + } + #assert str only has solo inner underscores (if any) between 'digits' + #------------------------------------------- + + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + + + + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements by default (for now) + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + #some question around implementations allowed to use lower values such as 2^31 on some systems? + if {$::tomlish::max_int ne "" && $numeric_value > $::tomlish::max_int} { + return 0 + } + if {$::tomlish::min_int ne "" && $numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + #note - Tcl's string is double will return true also for the subset of float values which are integers + #This function is to determine whether it matches the Toml float concept - so requires a . or e or E + proc is_float {str} { + #vip greenlight known literals, don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + #doorcheck the basics for floatiness vs members of that rival gang - ints + if {![regexp {[.eE]} $str]} { + #could be an integer - which isn't specifically a float for Toml purposes. + return 0 + } + + + #patdown for any contraband chars + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + + #all characters in legal range + + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + + #Early Toml spec also disallowed leading zeros in the exponent part(?) + #... this seems less interoperable anyway (some libraries generate leading zeroes in exponents) + #we allow leading zeros in exponents here. + + #Check for leading zeros in main part + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #----------------------------------------- + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_" || [string index $str end] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_ + if {[string index $utest 0] eq "_"} { + return 0 + } + #----------------------------------------- + + #decimal point, if used must be surrounded by at least one digit on each side + #e.g 3.e+20 also illegal + set dposn [string first . $str] + if {$dposn > -1 } { + set d3 [string range $str $dposn-1 $dposn+1] + if {![string is integer -strict [string index $d3 0]] || ![string is integer -strict [string index $d3 2]]} { + return 0 + } + } + #we've already eliminated leading/trailing underscores + #now ensure each inner underscore is surrounded by digits + if {[regexp {_[^0-9]|[^0-9]_} $str]} { + return 0 + } + + #strip underscores for tcl double check so we can support < tcl 9 versions which didn't allow underscores + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + #All good - seems to be a toml-approved float and not an int. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_datepart {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_localdate {str} { + is_datepart $str + } + proc is_timepart {str} { + set numchars [tcl::string::length $str] + #timepart can have negative or positive offsets so - and + must be accepted + if {[regexp -all {[zZt0-9\-\+\.:]} $str] == $numchars} { + #todo + #basic check that we have leading 2dig hr and 2dig min separated by colon + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}[^0-9]{1}.*$} $str]} { + #nn:nn or nn:nnX.* where X is non digit + return 0 + } + return 1 + } else { + return 0 + } + } + proc is_localtime {str} { + #time of day without any relation to a specific day or any offset or timezone + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\.:]} $str] == $numchars} { + #todo + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}:[0-9]{2}([.][0-9]*){0,1}$} $str]} { + #hh:mm or hh:mm:ss or hh:mm::ss.nnn + return 0 + } + return 1 + } else { + return 0 + } + } + + #review + proc is_datetime {str} { + #Essentially RFC3339 formatted date-time - but: + #1) allowing seconds to be omitted (:00 assumed) + #2) T may be replaced with a single space character TODO - parser support for space in datetime! + # (RFC 3339 allows space instead of T also - but doesn't specify it *must* be a single space) + + #toml-lint @2025-04 doesn't accept t for T or z for Z - but RFC3339 does + #toml spec doesn't clarify - we will accept + + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 not ok - 2024T not accepted by tomlint why? + # 02:00 ok + # 02:00:00.5 ok + # 1:00 - not ok - RFC3339 requires 2-digit hr,min,sec + + #toml-lint.com accepts 2025-01 + + if {[string length $str] < 5} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\ \-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + if {[regexp -all {\ } $str] > 1} { + #only a single space is allowed. + return 0 + } + #If we get a space - it is only valid as a convience to represent the T separator + #we can normalize by converting to T here before more tests + set str [string map {" " T t T} $str] + #a further sanity check on T + if {[regexp -all {T} $str] > 1} { + return 0 + } + + #!todo - use full RFC 3339 parser? + #!todo - what if the value is 'time only'? + + if {[string first T $str] > -1} { + lassign [split $str T] datepart timepart + if {![is_datepart $datepart]} { + return 0 + } + if {![is_timepart $timepart]} { + return 0 + } + } else { + #either a datepart or a localtime + #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day + # without any relation to a specific day or any offset or timezone." + if {!([is_datepart $str] || [is_localtime $str])} { + return 0 + } + } + + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # array-value-expected,keyval-value-expected,itable-keyval-value-expected, keyval-syntax, + # dquoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # xxx_value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + #--------------------------------------------------------- + #WARNING + #The stateMatrix implementation here is currently messy. + #The code is a mixture of declarative via the stateMatrix and imperative via switch statements during PUSH/POP/SAMESPACE transitions. + #This means the state behaviour has to be reasoned about by looking at both in conjuction. + #--------------------------------------------------------- + + #xxx-space vs xxx-syntax inadequately documented - TODO + + #review - out of date? + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> keyval-value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXsingle_dquote "quoted-key"\ + XXXsingle_squote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + enddquote "err-state"\ + endsquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-untyped-sequence" note "possible datetime datepart"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"} + + #untyped_value sequences without intervening comma are allowed for datepart timepart + #we will produce tomlish with missing SEPS and to_dict must validate whether 2 adjacent barekeys are valid + dict set stateMatrix\ + keyval-untyped-sequence {\ + whitespace "keyval-untyped-sequence"\ + untyped_value {TOSTATE "keyval-tail"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + #2025 - no leading-squote-space - only trailing-squote-space. + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + + #itable-space/ curly-syntax : itables + # x={y=1,} + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #we don't get single_squote etc here - instead we get the resulting squotedkey token + + + # ??? review - something like this + # + # x={y =1,} + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace {TOSTATE "itable-keyval-syntax"}\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal {TOSTATE "itable-keyval-value-expected"}\ + newline "err-state"\ + eof "err-state"\ + } + + # x={y=1} + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + single_dquote {TOSTATE "string-state" returnstate itable-val-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + single_squote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + #double_squote not currently generated by _start_squote_sequence - '' processed as single_squote to literal-state just like 'xxx' + # review + # double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"} + + + + # x={y=1,z="x"} + #POPSPACE is transition from itable-keyval-space to parent itable-space + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + newline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + comment "itable-val-tail"\ + eof "err-state"\ + } + # XXXnewline "POPSPACE" + # We shouldn't popspace on newline - as if there was no comma we need to stay in itable-val-tail + # This means the newline and subsequent whitespace, comments etc become part of the preceeding dottedkey record + #e.g + # x = { + # j=1 + # #comment within dottedkey j record + # , # comment unattached + # #comment unattached + # k=2 , #comment unattached + # l=3 #comment within l record + # , m=4 + # #comment associated with m record + # + # #still associated with m record + # } + ## - This doesn't quite correspond to what a user might expect - but seems like a consistent mechanism. + #The awkwardness is because there is no way to put in a comment that doesn't consume a trailing comma + #so we cant do: j= 1 #comment for j1 , + # and have the trailing comma recognised. + # + # To associate: j= 1, #comment for j1 + # we would need some extra processing . (not popping until next key ? extra state itable-sep-tail?) REVIEW - worth doing? + # + # The same issue occurs with multiline arrays. The most natural assumption is that a comment on same line after a comma + # is 'associated' with the previous entry. + # + # These comment issues are independent of the data dictionary being generated for conversion to json etc - as the comments don't carry through anyway, + # but are a potential oddity for manipulating the intermediate tomlish structure whilst attempting to preserve 'associated' comments + # (e.g reordering records within an itable) + #The user's intention for 'associated' isn't always clear and the specs don't really guide on this. + + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + eof "err-state"\ + newline "err-state"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - multiline itables appear to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + #dict set stateMatrix\ + # array-space {\ + # whitespace "array-space"\ + # newline "array-space"\ + # untyped_value "SAMESPACE"\ + # startarray {PUSHSPACE "array-space"}\ + # endarray "POPSPACE"\ + # startinlinetable {PUSHSPACE itable-space}\ + # single_dquote "string-state"\ + # single_squote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + # comma "array-space"\ + # comment "array-space"\ + # eof "err-state-array-space-got-eof"\ + # } + + ## array-space ## + set aspace [dict create] + dict set aspace whitespace "array-space" + dict set aspace newline "array-space" + #dict set aspace untyped_value "SAMESPACE" + dict set aspace untyped_value "array-syntax" + dict set aspace startarray {PUSHSPACE "array-space"} + dict set aspace endarray "POPSPACE" + dict set aspace single_dquote {TOSTATE "string-state" returnstate array-syntax} + dict set aspace triple_dquote {PUSHSPACE "multistring-space" returnstate array-syntax} + dict set aspace single_squote {TOSTATE "literal-state" returnstate array-syntax} + dict set aspace triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax} + dict set aspace startinlinetable {PUSHSPACE itable-space} + #dict set aspace comma "array-space" + dict set aspace comment "array-space" + dict set aspace eof "err-state-array-space-got-eof" + dict set stateMatrix array-space $aspace + + #when we pop from an inner array we get to array-syntax + #e.g {x=[[]] ??? + set tarntail [dict create] + dict set tarntail whitespace "tablearrayname-tail" + dict set tarntail newline "err-state" + dict set tarntail comment "err-state" + dict set tarntail eof "err-state" + dict set tarntail endtablename "tablearray-tail" + dict set stateMatrix tablearrayname-tail $tarntail + + #review - somewhat counterintuitive...? + # [(starttablearrayname) (endtablearrayname] + # [(starttablename) (endtablename)] + + # [[xxx]] ??? + set tartail [dict create] + dict set tartail whitespace "tablearray-tail" + dict set tartail newline "table-space" + dict set tartail comment "tablearray-tail" + dict set tartail eof "end-state" + dict set stateMatrix tablearray-tail $tartail + + + + + + + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #use dict set to add values so we can easily add/remove/comment lines + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions [dict create] + dict set spacePushTransitions keyval-space keyval-syntax + dict set spacePushTransitions itable-keyval-space itable-keyval-syntax + dict set spacePushTransitions array-space array-space + dict set spacePushTransitions table-space tablename-state + #dict set spacePushTransitions #itable-space itable-space + + #Pop to, next + variable spacePopTransitions [dict create] + dict set spacePopTransitions array-space array-syntax + + + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from keyval-value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions [dict create] + #JMN test + #dict set spaceSameTransitions array-space array-syntax + + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + set popfromspace_info [spacestack peek] + set popfromspace_state [dict get $popfromspace_info state] + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + ::tomlish::log::debug "--->> zeropoppushspace goNextState RECURSE. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + #for multiliteral, multistring - data and/or end + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo token beginning with underscore - never returned to state machine - review + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\{" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename - tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow: + # table -> starttablearrayname + # tablearray -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + array-syntax - array-space { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-tail { + #[[xxx] + set_tokenType "endtablename" + #sequence: starttablename -> starttablearrayname -> endtablearrayname -> endtablename + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + string - dquotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + #for within multiliteral + #short tentative_accum_squote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_squote is multisquote + 2 = 5 + #return tok with value ''''' + return 1 + } + } + tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multiliteral + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + #if there are more than 3 leading squotes we also enter multiliteral space and the subsequent ones are handled + #by the tentative_accum_squote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 squotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to a tentative_accum_squote token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #barekeys now support all sorts of unicode letter/number chars for other cultures + #but not punctuation - not even for those of Irish heritage who don't object + #to the anglicised form of some names. + # o'shenanigan seems to not be a legal barekey + #The Irish will have to use an earlier form Ó - which apparently many may prefer anyway. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading squote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_squote token or triple_squote token + #It currently doesn't trigger double_squote token + #(handle '' same as 'x' ie produce a single_squote and go into processing literal) + #review - producing double_squote for empty literal may be slightly more efficient. + #This token is not used to handle squote sequences *within* a multiliteral + set_tokenType "_start_squote_sequence" + set tok "'" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_squote" ;#trigger tentative_accum_squote + set tok "'" + return 1 + } + table-space - itable-space { + #tests: squotedkey.test squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXtable-space - XXXitable-space { + #future - could there be multiline keys? MLLKEY, MLBKEY ? + #this would (almost) allow arbitrary tcl dicts to be stored in toml (aside from escaping issues) + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + #@2025 ABNF for toml mentions key, simple-key, unquoted-key, quoted-key and dotted-key + #where key is simple-key or dotted-key - no MLL or MLB components + #the spec states solution for arbitrary binary data is application specific involving encodings + #such as hex, base64 + set_tokenType "_start_squote_sequence" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType "tablename" + append tok "'" + } + tablearrayname-state { + set_tokenType "tablearrayname" + append tok "'" + } + literal-state { + #shouldn't get here? review + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType "literal" + incr -1 + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + #error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + dottedkey-space { + set_tokenType "squotedkey" + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + tentative_accum_dquote { + #within multistring + #short tentative_accum_dquote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_dquote is multidquote + 2 = 5 + #return tok with value """"" + return 1 + } + } + _start_dquote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multistring + #switch? + append tok $c + set_tokenType triple_dquote + return 1 + } + default { + #if there are more than 3 leading dquotes we also enter multistring space and the subsequent ones are handled + #by the tentative_accum_dquote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 dquotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_dquote_sequence'" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + incr i -1 ;#throw the {"} back to loop - will be added to a tentative_accum_dquote token for later processing + return 1 + } + } + whitespace { + #assert: had_slash will only ever be true in multistring-space + if {$had_slash} { + incr i -2 + return 1 + } else { + #end whitespace token - throw dq back for reprocessing + incr i -1 + return 1 + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type enddquote value {"} complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading dquote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_dquote token or triple_dquote token + #It currently doesn't trigger double_dquote token + #(handle "" same as "x" ie produce a single_dquote and go into processing string) + #review - producing double_dquote for empty string may be slightly more efficient. + #This token is not used to handle dquote sequences once *within* a multistring + set_tokenType "_start_dquote_sequence" + set tok {"} + } + multistring-space { + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + } else { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_dquote" ;#trigger tentative_accum_dquote + set tok {"} + return 1 + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + default { + error "tomlish Unexpected dquote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0 + append tok $c + } + string - comment - dquotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok = + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + #multiliteral or multistring + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + #review + if {$had_slash} { + incr i -2 + } else { + incr i -1 + } + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $c + } + string - dquotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART xxx WS " " + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + append tok $c + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #assert - tok will be one or two squotes only + #A toml literal probably isn't allowed to contain this + #but we will parse and let the validator sort it out. + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart { + append tok $c + } + string - stringpart { + append tok $c + } + default { + #state machine will generally not have entry to accept bom - let it crash + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + multistring-space { + set_tokenType "stringpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + set tok \\$c + } else { + set tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "literal" + set tok "" + return 1 + + ##review + #set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + #set_tokenType "literal" + #set tok "" + #return 1 + } + } + } + _start_dquote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open string + error "tomlish eof reached without closing double quote for string. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "string" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + + proc _show_tablenames {tablenames_info} { + append msg \n "tablenames_info:" \n + dict for {tkey tinfo} $tablenames_info { + append msg " " "table: $tkey" \n + dict for {field finfo} $tinfo { + append msg " " "$field $finfo" \n + } + } + return $msg + } +} +tcl::namespace::eval tomlish::to_dict { + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "preval" ;#5 modes: preval, quoted,litquoted, unquoted, postval + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + #todo - track\count backslashes properly + + set c [tcl::string::index $tablename $i] + if {$c eq "\""} { + if {($lastChar eq "\\")} { + #not strictly correct - we could have had an even number prior-backslash sequence + #the toml spec would have us error out immediately on bsl in bad location - but we're + #trying to parse to unvalidated tomlish + set ctest escq + } else { + set ctest dq + } + } else { + set ctest [string map [list " " sp \t tab] $c] + } + + switch -- $ctest { + . { + switch -exact -- $mode { + preval { + error "tablename_split. dot not allowed - expecting a value" + } + unquoted { + #dot marks end of segment. + if {![tomlish::utils::is_barekey $seg]} { + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + set seg "" + set mode "preval" + } + quoted { + append seg $c + } + litquoted { + append seg $c + } + postval { + #got dot in an expected location + set mode "preval" + } + } + } + dq { + #unescaped dquote + switch -- $mode { + preval { + set mode "quoted" + set seg "\"" + } + unquoted { + #invalid in barekey - but we are after structure only + append seg $c + } + quoted { + append seg $c + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" ;#make sure we only accept a dot or end-of-data now. + } + litquoted { + append seg $c + } + postval { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } + } + ' { + switch -- $mode { + preval { + append seg $c + set mode "litquoted" + } + unquoted { + #single quote inside e.g o'neill - ultimately invalid - but we pass through here. + append seg $c + } + quoted { + append seg $c + } + litquoted { + append seg $c + #no normalization to do aside from stripping squotes + if {$normalize} { + lappend segments [tcl::string::range $seg 1 end-1] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" + } + postval { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + } + } + sp - tab { + switch -- $mode { + preval - postval { + #ignore + } + unquoted { + #terminates a barekey + lappend segments $seg + set seg "" + set mode "postval" + } + default { + #append to quoted or litquoted + append seg $c + } + } + } + default { + switch -- $mode { + preval { + set mode unquoted + append seg $c + } + postval { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + default { + append seg $c + } + } + } + } + + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + switch -exact -- $mode { + preval { + error "tablename_split. Expected a value after last dot separator. tablename: '$tablename'" + } + unquoted { + if {![tomlish::utils::is_barekey $seg]} { + #e.g toml-test invalid/table/with-pound required to fail for invalid barekey + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + } + quoted { + error "tablename_split. Expected a trailing double quote. tablename: '$tablename'" + } + litquoted { + error "tablename_split. Expected a trailing single quote. tablename: '$tablename'" + } + postval { + #ok - segment already lappended + } + } + } + } + + #note - we must allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + + return $segments + } + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + proc get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish::to_dict::get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "tomlish::to_dict::get_dottedkey_info DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + +} + + +tcl::namespace::eval tomlish::app { + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + tcl::namespace::eval argdoc { + proc test_suites {} { + if {[package provide test::tomlish] eq ""} { + return [list] + } + return [test::tomlish::SUITES] + } + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::decoder + @cmd -name tomlish::app::decoder -help\ + "Read toml on stdin until EOF + on error - returns non-zero exit code and writes error to + the errorchannel. + on success - returns zero exit code and writes JSON encoding + of the data to the outputchannel. + This decoder is intended to be compatble with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help\ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc decoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::decoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::decoder] + } + + #fconfigure stdin -encoding utf-8 + fconfigure $ch_input -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts $ch_error "decoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $j + exit 0 + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::encoder + @cmd -name tomlish::app::encoder -help\ + "Read JSON on input until EOF + return non-zero exitcode if JSON data cannot be converted to + a valid TOML representation. + return zero exitcode and TOML data on output if JSON data can + be converted. + This encoder is intended to be compatible with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help \ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc encoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::encoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::encoder] + } + #review + fconfigure $ch_input -translation binary + if {[catch { + set json [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts $ch_error "encoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $toml + exit 0 + } + + punk::args::define { + @dynamic + @id -id ::tomlish::app::test + @cmd -name tomlish::app::test + @leaders + @opts -any 1 + -help -type none -help\ + "Display this usage message + or further info if more args." + -suite -default tests -choices {${[::tomlish::app::argdoc::test_suites]}} + @values -min 0 -max -1 + } + proc test {args} { + package require test::tomlish + set argd [punk::args::parse $args withid ::tomlish::app::test] + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + set solos [dict get $argd solos] + set opt_suite [dict get $opts -suite] + if {[dict exists $received -help] && ![dict exists $received -suite]} { + return [punk::args::usage -scheme info ::tomlish::app::test] + } + + test::tomlish::SUITE $opt_suite + #if {[catch {test::tomlish::SUITE $opt_suite} errM]} { + # puts stderr "Unknown test suite '$opt_suite'. Available suites: [test::tomlish::SUITES]" + # exit 1 + #} + set run_opts [dict remove $opts -suite] + set run_opts [dict remove $run_opts {*}$solos] + set result [test::tomlish::RUN {*}$run_opts {*}$solos {*}$values] + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {[info exists ::argc] && $::argc > 0} { + #puts stderr "argc: $::argc args: $::argv" + set arglist $::argv + # -------------- + #make sure any dependant packages that are sourced don't get any commandline args + set ::argv {} + set ::argc 0 + # -------------- + package require punk::args + punk::args::define { + @dynamic + @id -id tomlish::cmdline + @cmd -name tomlish -help\ + "toml encoder/decoder written in Tcl" + @opts -any 1 + -help -type none -help\ + "Display this usage message or more specific + help if further arguments provided." + -app -choices {${[tomlish::appnames]}} + } + try { + set argd [punk::args::parse $arglist withid tomlish::cmdline] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + puts stderr $msg + exit 1 + } + + + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received -help] && ![dict exists $received -app]} { + #only emit cmdline help if -app not supplied as well - otherwise app function can act on -help for more specific help + #puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + puts stdout [punk::args::usage -scheme info tomlish::cmdline] + exit 0 + } + if {![dict exists $received -app]} { + puts stderr [punk::args::usage -scheme error tomlish::cmdline] + exit 1 + } + + set app [dict get $opts -app] + set appnames [tomlish::appnames] + set app_opts [dict remove $opts -app {*}$solos] + try { + set result [tomlish::app::$app {*}$app_opts {*}$solos {*}$values] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + #The validation error should fully describe the issue + #no need for errortrace - keep the output cleaner + puts stderr $msg + exit 1 + } trap {} {msg erroropts} { + #unexpected error - uncaught throw will produce error trace + #todo - a support msg? Otherwise we may as well just leave off this trap. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + if {"-help" in $solos} { + puts stderr $result + exit 1 + } else { + if {$result ne ""} { + puts stdout $result + exit 0 + } + } + + #set opts [dict create] + #set opts [dict merge $opts $::argv] + + #set opts_understood [list -app ] + #if {"-app" in [dict keys $opts]} { + # #Don't vet the remaining opts - as they are interpreted by each app + #} else { + # foreach key [dict keys $opts] { + # if {$key ni $opts_understood} { + # puts stderr "Option '$key' not understood" + # exit 1 + # } + # } + #} + #if {[dict exists $opts -app]} { + # set app [dict get $opts -app] + # set appnames [tomlish::appnames] + # if {$app ni $appnames} { + # puts stderr "app '[dict get $opts -app]' not found. Available apps: $appnames" + # exit 1 + # } + # tomlish::app::$app {*}$opts + #} +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.5 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index f7730214..46e0b453 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -612,6 +612,14 @@ tcl::namespace::eval punk::args { # form_defs $F\ #] } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } proc define {args} { dict get [resolve {*}$args] id } @@ -2431,7 +2439,7 @@ tcl::namespace::eval punk::args { tableobject "table object cmd" table "full table laout" } - -scheme -choices {nocolour info error} + -scheme -default error -choices {nocolour info error} }] ] #basic recursion blocker @@ -3113,8 +3121,6 @@ tcl::namespace::eval punk::args { } set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) if {$use_table} { #assert returntype is one of table, tableobject set result $errmsg ;#default if for some reason table couldn't be used @@ -3127,7 +3133,9 @@ tcl::namespace::eval punk::args { set result $errmsg } if {$as_error} { - return -code error -errorcode {TCL WRONGARGS PUNK} $result + #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 } @@ -3153,7 +3161,7 @@ tcl::namespace::eval punk::args { mechanism and call punk::args::usage as necessary. " -return -default table -choices {string table tableobject} - } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { @values -min 0 -max 1 id -help\ @@ -3232,7 +3240,7 @@ tcl::namespace::eval punk::args { entries." #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard minimal} + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} @values -min 2 @@ -3282,11 +3290,20 @@ tcl::namespace::eval punk::args { if {[llength $opts] % 2} { error "punk::args::parse Even number of -flag val pairs required after arglist" } + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) set defaultopts [dict create\ -form {*}\ -errorstyle enhanced\ ] - set opts [dict merge $opts $defaultopts] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + + set opts [dict merge $defaultopts $opts] dict for {k v} $opts { switch -- $k { -form - -errorstyle { @@ -3322,18 +3339,77 @@ tcl::namespace::eval punk::args { } try { set result [punk::args::get_dict {*}$deflist $parseargs] - } trap {PUNKARGS} {msg opts} { - #trap punk::args argument validation/parsing errors and decide here - #whether to display basic error - or full usage if configured. - puts stderr "PUNKARGS: $msg\n$opts" - return - } trap {} {msg opts} { + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { #review - #puts stderr "$msg\n$opts" #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $opts -errorcode] [dict get $opts -errorinfo] - return + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] } return $result } @@ -3453,6 +3529,7 @@ tcl::namespace::eval punk::args { #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 @@ -3671,7 +3748,9 @@ tcl::namespace::eval punk::args { #incr i to skip flagval incr vals_remaining_possible -2 if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt } } else { #solo @@ -3686,6 +3765,7 @@ tcl::namespace::eval punk::args { tcl::dict::set opts $fullopt 1 } incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok } lappend flagsreceived $fullopt ;#dups ok } else { @@ -3714,7 +3794,9 @@ tcl::namespace::eval punk::args { tcl::dict::set opts $a $newval } if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + 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 { @@ -3729,15 +3811,17 @@ tcl::namespace::eval punk::args { tcl::dict::set opts $a 1 } incr vals_remaining_possible -1 + lappend solosreceived $a } lappend flagsreceived $a ;#adhoc flag as supplied } else { if {[llength $OPT_NAMES]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" } - arg_error $errmsg $argspecs -badarg $fullopt + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt } } } @@ -3839,14 +3923,20 @@ tcl::namespace::eval punk::args { if {$leadermax == -1} { #only check min if {$num_leaders < $leadermin} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs } } else { if {$num_leaders < $leadermin || $num_leaders > $leadermax} { if {$leadermin == $leadermax} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs } } } @@ -3854,14 +3944,20 @@ tcl::namespace::eval punk::args { if {$val_max == -1} { #only check min if {$num_values < $val_min} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs } } else { if {$num_values < $val_min || $num_values > $val_max} { if {$val_min == $val_max} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs } else { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs } } } @@ -3888,13 +3984,19 @@ tcl::namespace::eval punk::args { #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + 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 [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { - arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs } if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { - arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + 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 } @@ -4007,11 +4109,11 @@ tcl::namespace::eval punk::args { #----------------------------------- #fast fail on the wrong number of choices if {[llength $c_list] < $choicemultiple_min} { - set msg "Option $argname for [Get_caller] requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg } if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg } #----------------------------------- @@ -4142,7 +4244,10 @@ tcl::namespace::eval punk::args { } else { set prefixmsg "" } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + #review: $c vs $c_check for -badval? + set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname } } incr choice_idx @@ -4178,7 +4283,9 @@ tcl::namespace::eval punk::args { #do not run ta::detect on a list foreach e $vlist { if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + set msg "Option '$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 + #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" } } } @@ -4200,7 +4307,9 @@ tcl::namespace::eval punk::args { list { foreach e_check $vlist_check { if {![tcl::string::is list -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname } if {[tcl::dict::size $thisarg_checks]} { tcl::dict::for {checkopt checkval} $thisarg_checks { @@ -4208,13 +4317,17 @@ tcl::namespace::eval punk::args { -minsize { # -1 for disable is as good as zero if {[llength $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname } } -maxsize { if {$checkval ne "-1"} { if {[llength $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname } } } @@ -4255,11 +4368,13 @@ tcl::namespace::eval punk::args { #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 "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" + set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" } - arg_error $msg $argspecs -badarg $argname + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error $msg $argspecs -badarg $argname } } } @@ -4273,14 +4388,18 @@ tcl::namespace::eval punk::args { package require punk::ansi foreach e $remaining_e { if {![punk::ansi::ta::detect $e]} { - arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname } } } globstring { foreach e $remaining_e { if {![regexp {[*?\[\]]} $e]} { - arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname } } } @@ -4295,13 +4414,17 @@ tcl::namespace::eval punk::args { -minsize { # -1 for disable is as good as zero if {[tcl::string::length $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname } } -maxsize { if {$checkval ne "-1"} { if {[tcl::string::length $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname } } } @@ -4318,31 +4441,43 @@ tcl::namespace::eval punk::args { if {$low eq ""} { foreach e $vlist e_check $vlist_check { if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } #lowside unspecified - check only high if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname } } } elseif {$high eq ""} { foreach e $vlist e_check $vlist_check { if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } #highside unspecified - check only low if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname } } } else { foreach e $vlist e_check $vlist_check { if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } #high and low specified if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname } } } @@ -4350,7 +4485,9 @@ tcl::namespace::eval punk::args { } else { foreach e_check $vlist_check { if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname } } } @@ -4358,7 +4495,9 @@ tcl::namespace::eval punk::args { double { foreach e $vlist e_check $vlist_check { if {![tcl::string::is double -strict $e_check]} { - error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + set msg "Option $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 + #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" } if {[tcl::dict::size $thisarg_checks]} { #safe jumptable test @@ -4370,7 +4509,9 @@ tcl::namespace::eval punk::args { #todo - empty string for low or high lassign $checkval low high if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname } } } @@ -4381,14 +4522,18 @@ tcl::namespace::eval punk::args { bool { foreach e_check $vlist_check { if {![tcl::string::is boolean -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname } } } dict { foreach e_check $vlist_check { if {[llength $e_check] %2 != 0} { - arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname } if {[tcl::dict::size $thisarg_checks]} { tcl::dict::for {checkopt checkval} $thisarg_checks { @@ -4396,13 +4541,17 @@ tcl::namespace::eval punk::args { -minsize { # -1 for disable is as good as zero if {[tcl::dict::size $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname } } -maxsize { if {$checkval ne "-1"} { if {[tcl::dict::size $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname } } } @@ -4426,12 +4575,13 @@ tcl::namespace::eval punk::args { xdigit { foreach e $vlist e_check $vlist_check { if {![tcl::string::is $type $e_check]} { - set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" #try trap? #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result #throw ? - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - arg_error $msg $argspecs -badarg $argname + set msg "Option $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 + #arg_error $msg $argspecs -badarg $argname } } } @@ -4443,27 +4593,36 @@ tcl::namespace::eval punk::args { #//review - we may need '?' char on windows if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { #what about special file names e.g on windows NUL ? - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname } } if {$type eq "existingfile"} { foreach e $vlist e_check $vlist_check { if {![file exists $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname } } } elseif {$type eq "existingdirectory"} { foreach e $vlist e_check $vlist_check { if {![file isdirectory $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname } } } } char { + #review - char vs unicode codepoint vs grapheme? foreach e $vlist e_check $vlist_check { if {[tcl::string::length $e_check] != 1} { - arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname } } } @@ -4515,7 +4674,7 @@ tcl::namespace::eval punk::args { #(e.g using 'dict exists $received -flag') # - but it can have duplicate keys when args/opts have -multiple 1 #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] } #proc sample1 {p1 args} { diff --git a/src/modules/punk/args-buildversion.txt b/src/modules/punk/args-buildversion.txt index f47d01c8..7e019aff 100644 --- a/src/modules/punk/args-buildversion.txt +++ b/src/modules/punk/args-buildversion.txt @@ -1,3 +1,3 @@ -0.1.0 +0.1.4 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/shellfilter-0.1.9.tm b/src/modules/shellfilter-0.1.9.tm index d70d657c..92b214d8 100644 --- a/src/modules/shellfilter-0.1.9.tm +++ b/src/modules/shellfilter-0.1.9.tm @@ -759,7 +759,7 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [llength $buf]-1} { + if {[string last \x1b $buf] == [string length $buf]-1} { #only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b @@ -769,7 +769,7 @@ namespace eval shellfilter::chan { #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer if {[punk::ansi::ta::detect_st_open $buf]} { #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code #todo - configurable ST max - use 1k for now if {$st_partial_len < 1001} { append o_buffered $chunk @@ -778,7 +778,7 @@ namespace eval shellfilter::chan { set emit_anyway 1 } } else { - set possible_code_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of possible code + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 971d7331..2a097fd2 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -152,7 +152,8 @@ tcl::namespace::eval textblock { hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} } proc use_hash {args} { - set argd [punk::args::get_by_id ::textblock::use_hash $args] + #set argd [punk::args::get_by_id ::textblock::use_hash $args] + set argd [punk::args::parse $args withid ::textblock::use_hash] variable use_hash if {![dict exists $argd received hash_algorithm]} { return $use_hash @@ -4143,7 +4144,8 @@ tcl::namespace::eval textblock { proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + #set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opts [dict get [punk::args::parse $args withid ::textblock::periodic] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -7913,7 +7915,8 @@ tcl::namespace::eval textblock { #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { #as frame is called a lot within table building - checking args can have a *big* impact on final performance. - set argd [punk::args::get_by_id ::textblock::frame $args] + #set argd [punk::args::get_by_id ::textblock::frame $args] + set argd [punk::args::parse $args withid ::textblock::frame] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8650,7 +8653,7 @@ tcl::namespace::eval textblock { size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id ::textblock::gcross $args] + set argd [punk::args::parse $args withid ::textblock::gcross] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.1.tm new file mode 100644 index 00000000..2d8de97d --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.1.tm @@ -0,0 +1,5341 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.0] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + return -code error -errorcode {TCL WRONGARGS PUNK} $result + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + set opts [dict merge $opts $defaultopts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg opts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + ##try trap? + ##return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + ##throw ? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg + #arg_error $msg $argspecs -badarg $argname + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $::errorCode] $::errorInfo + } + standard { + puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" + } + enhanced { + puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" + } + } + return + } trap {PUNKARGS} {msg opts} { + #trap punk::args argument validation/parsing errors and decide here + #whether to display basic error - or full usage if configured. + puts stderr "PUNKARGS OTHER: $msg\n$opts" + #JJJ + return + } trap {} {msg opts} { + #review + #puts stderr "$msg\n$opts" + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $opts -errorcode] [dict get $opts -errorinfo] + return + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lapend solosreceived $fullopt + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" + } + arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } else { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for [Get_caller] requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg + arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm new file mode 100644 index 00000000..95d5c702 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm @@ -0,0 +1,5473 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.4 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.4] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -default error -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + 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 [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "Option '$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 + #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "Option $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 + #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + set msg "Option $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 + #arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index a099c9b0..4c0ab79d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -661,7 +661,11 @@ namespace eval punk::mix::cli { puts stdout "$current_source_dir/$modpath" puts stdout "to:" puts stdout "$podtree_copy" + #REVIEW + #todo - copy manually - renaming any files/folders with 999999.0a1.0 in the name to the applicable version + #(allow either shared files/folders or custom files/folders per package/version when in extracted form side by side) file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm if {[file exists $tmfile]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm index d70d657c..92b214d8 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm @@ -759,7 +759,7 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [llength $buf]-1} { + if {[string last \x1b $buf] == [string length $buf]-1} { #only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b @@ -769,7 +769,7 @@ namespace eval shellfilter::chan { #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer if {[punk::ansi::ta::detect_st_open $buf]} { #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code #todo - configurable ST max - use 1k for now if {$st_partial_len < 1001} { append o_buffered $chunk @@ -778,7 +778,7 @@ namespace eval shellfilter::chan { set emit_anyway 1 } } else { - set possible_code_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of possible code + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm new file mode 100644 index 0000000000000000000000000000000000000000..536e3fa3bf724e2b979b4a297a88d29d74284f07 GIT binary patch literal 51527 zcmce;1zc2H+dhmS-67Hp-5t{1AkvNG&^a@-fTT2%BB26;q@*HUN{N7klyr%xq!J>0 zd%%EmJm-C$_w)VF@3$Cc_TFn<>$-E@d+oshoq5su+Pi^l?47_MFMF6BNXNol~yepV1 z$l2Ay1qSl6gLevi& zXbW}$LoDE(dO+=6Y()Tw@UBHfoa`+{M4T-g!Davkv(s-u9IiGtP%sSU;|2y@CWIGiO3kQmJQvbO>G8CzMvtn5I3CuF*~LYys}?0vx?V|y1HR}j<+V($hs z^@ooPKLPm9?_3XXg1`_6Kqc*W7$>a2JS@q zEMRt=AZ9mLDAXQ)4%EU146p;7@AyDqcMvTt z=*A5Yjq%BZz~1&y7!>s5_@Bp53pxkpJTyQY@VQ#sLqMl+fd5?JqW_8K+{NEdH?wfD zHUre=`!x_(SJ=r#r(M7-?45pHZ+fl+Ckuc{TNjWq)Xm8rc5>Fw&NxiJ(|*#ycda~k z^@%q8l{Ek{*AJD3qyEv~Z<&O;dO)mBXZKInah>f1(ED=;{6SzRDEK!jM)x<}finUH zYz)vESCAJNWM$z3%nxqC7H)13S2u_~U^q@b=emb0D{#!}RL7uTD;UU68YJ^Oora%! z!iSR+*u@s`F!a)Ay`Eei;6OpCS#Sm-*KdWI*&lH@`jQ_f!2bu;1?w+qgo&7JzT@29SaL;3qTF zd$ar_ac54K`Hc>oPUJhkC*JA1albF?Hu8!{eB|9|Mt5c z{Fbx7Ujd)Kla&P&Y9>4|0ivXQ?W{htg5?gr1Gc7j;A*aBhi zEc#Q|ZFH>s+(D_bI;sy|(;XRvzL`2{-gkK9f zi9)V6K-@k_Z9qWg0?gbRp3waG3UZoq{dR6A$^v)MX26i&V+z+P;U{SPSpClfF@;AS z;C!$(2OtV~Qgt?X{B4YXj2>{x|4IP7r|)z8TSq_6KNvjV8dX^Q;gsuNspfWpAw-@~=w_niPq zDiDu(xq10GxP?VP=R5g+FoENSi8C~!QgrYVmgzHFae1<*aZXwvO>74{DlY# zB#=;7Af@_&9Rw(s6W9U@1KGkeU}tzr1iV{=oh*EyARrOTP(Cl{J`0J--obUof1ZyDk1v!ENz{Y=9kbicjv|L=LsszunP7RF~ zB5)z9@2W z1w`j&eZmRH_sr~6ppGuCUcj>CobJL^)YSt9fOtfcFF3 zKcIG}PT$7f8&JR#BydCi_ksSNUi^UY&qq#WdRD{#F2>(38vnZZ`yVBIj)K!10Q5t; zC*pv6`~T(O-vtjy?v$#N{(#VDeCDI+zms>)*?72|BKi%Uf3=YB<&$4^5*r{uov6u= zwKlvw1mswNiJTN+P6F0x`U0Xqlhpk)*58ZL|My;i4)8^%RG&+?Ku`}$U?l=9nq2|Y zw{Y@;hf{bcgeMySI-tV#v+M*c$$|0%d`W(qlX!w%?19q&hx)5d24p{Q?LEB|kRm)3 z|CXokMTP&Rl>gS{zh;SaHWp4!mOy$7Hz>IC2Mq2<4)wR5;D$n{F2f1Z2hxj^ti=k* z>w)MAr{W|Fa0Xk$%Mc)dHz{B)N8 zYC!Poe|X-%_e_y~m126!arB${8606g??rE22%efX1KpB5_&+(o0 zlcFPBD^IBhbn~QUYz?yX0rEr_4?y$+|y{uL0_iIe+jc<_ae6Hs&F{AW{xqx}m~ z9iX3+YB5k!1_8MdkVL>G4~+KRJb;B3JY@iSxA;*Mh9}v-YRPZ_KUw^4YbPaSH(;WG z`F*b~1L@cgsQ(V|)aB3vRQ^_};dA&`Gl8D~f1NC&h%GlkxWAs=^_yV0sCbdh%gZl7=dqp z#2=WeGf=X!tPYf;=5|2o8 z5~<;rCqsof$oaIEz^|NEBlA>+zu~*wfniFUtLE#ea?_ec2?xvPX6;P4j4xN&?rfI@ zDDQoJNj>{w`?6$MT7y64m3J&CLU*F3XGmqmkXKN~K5mY!6(ze|xV$QVz-OEI;wp>S z>&G{_dStw&-wQ zm#Cwjr5?L9+AD?gJ;8c-fTXKfzY^Q1jpNddxw#l5?+)AR2LzZf;SVmsA`M?*jr|Bp zbwwIJV+`mwh%N=UYiwVYLAJf#|BS4Vs{yH_eDGo<{WzcCru}U~lniu&_#Dya#nO05M@%SU8dPHmn1YORG&hn2&o$Vzz zSHA=W!nU1xRMP3TFo_L`DAOC2$*(1t4Vfk0!ZKh9QGQguMqe1y)ON*yE`9ts^=i@n zhn;%?{R;+~jzY9?kL+iPFFcm>;V<^Y_fmeFG*04NXv#>tpBVdvYoASjFlvzcjRqS? zC4I;@R*=a-Q_2vXO}1*#Qn+Vw7FzGzmMuHeSOcx1;m0x)dVjh9(}MV15KWII-K5S? z-cyU7mJ&Vb*I}2oZcjdVjFG9#5aRu2K$x@a%ePdwgBe#O&UNFb!dN>=eJ?-Ff*Vqa z+Hocf8gop)M(B~JSW#79yU|ILZuv+Ld8qixvrPz7O5GP4o5!4#ZQPvMH&+(yxR=qOE>&_<(FTHMh-RtTnPdq z{15OFLO}UX{E8X8#02#KiXc!fOQ4d=3IBY24D@mV3E@}o4a^ZnO2+vyMi>YPcESh< z*AP(u+uq@s08sh&umbKTfw|6o`aUQUFeu_jV`nItFu_s7(IwL{{pp8@hFw#aADej9 zhE73EEnS5lLX1Omp2r}(Xt(pEFE@-j4wy<@ro>vHpMKcqRNDS7kKqZGxUUge9PP4c z70a!(<0d>F)Q`yNZ2mB!N@4x9mqA>H2veL4lcAsSXPMYQ%Ly?8mnu@~ryk`$Pka#^ zi&X7K?tTs0j2)}M)0wngim^2 zH#3pvar2Q4`M~y4V^Atf+@*`pwhW&8n`h$&4TyC}PxWp@lgpwtbJ2gn*D4;nvzmF! z7m0f4lR!maG@80ebB5JwS^2Jg0PjT!=XT!#bL!8E;x1U)x3UCMokiJu59e;V=Pq65 z6%FHA;cyVf4NY%t@n7|1s>qCghpt{;Ymu$ck`u9@l*M+m9={@suV{fmzq+sG{4Ke9Nit- z33l{4D0O=LUaI+>xS6-_tzDI;sQK>%%(Ax+X%4^bq2OOhif*~ZG68-dC-j0L2TZiV zfLp-Kjf`F(Re-e+id!BbGBLwEF1cyygCsss9D%#8OE_sZT=qUtp(-GIt|#W%-JaP* z%Edx{B6nPfOO)5ln*5W%9Jw7=& z8c;xeXo#Vsj_(I-wAG$`BpOQnh|~kCT(L0iqu!5Z#-nN{10Rf%=CXOefB6WHFX*sU zX4akE>MgQ2T9CCwVl$dMarA|Bk z@XE!fH4Y+gmvgl4_#S_IvWubbUghQC;q#;n*8X5DN#a(L%cxjG+btwYBSAq6S`a?{ z6svpPfR|$)x_03l|IC0r>-sFeg`&yKy4mL$v(GIWqq^%J>$Zy-qmN?!Da+X%W1`(? zhiI}EWV>?}y|j+=d%k339bS*0T-)}!+rDPZUgdeO(5niDuWaax!}m46L^D1GpY;Z< z%-})lEq}RqMLw&+F#LDSomXR#YEvXSX`-NA^n)+JGX=qxwv;M?&yNkCRbIPhhu$eR z&#t?RVW2jkP}H)408YJXq6EtBEx??6viNk$P0*b)Wmwd{g7$9j{&s zt=^3Zr4EUB#oFTBFJC6<+j3+kl8)Ni3u*GDaPLm+rQNZ8kMO1#p}7%x-}rO#C71Fh zaYs?o(XDqr9&g66ig{nI5A$T+WfkOS*PN@!GMm6CF>{f_Yl-0yHhA+u)?k60HF&yS zpvLW9^@H)vjUWni~Si4tR|Ggw6a_#o%rnhL~?QS5abSx{0@%8m5<11bv?Vuj^W%r@Z z0Wi|h74;)%_B)0Cs6tWC*IXE(^WKhb%M$t3W17(sovFe#vz?2HIP7gJ{fcqof#ghk zJZiiC7G3ti>(pwV#d5cYTeLn6FB&5ZIXlXi*FJTt6Y#THt9$W8ktM$1AgX}(y{xKP zPE?wzm!Y52^~H*GwYi8o!6%!%CV93;J4VPa@=_BB0%YWwX1H;&DjGZgCZaq;~cBLIpUUEAAQ_y3RDOUE$*V ziZi)&kWH+cH#eo_)|<++Wh>A43w!vP0a5hg{0@db+ZPxb;b_$*pYz zbsjvYj!+wCT%cTd6S4*?P|tWzL2|?Vj)Q`tL9WeBI?)k9PXuqt03L65>E399S8P;j z=}Ln)$S@lbLv)b|7X_dm7Asv{h;0u;z%O~W%L0RltVpZPzpXlzE0B7BnZJu4V!MW2 zC`}?FaqQ;dv#H9vXahlZj(4kU+qurt=B-ap#uup38?KrN)-5FjEZ%UT2%e2tN}Rl~ zU_Q(`{2_I^^PBC;qrRDR$#0({`4IR@=|=pIOghFTSd^;n!0mJTmkPEHoZQn+el-n=|_5Nru{eYzC(fHxsXK8&4e$@h?wh ziF{z@6~^L@S9e)bU(j|gdUtUU)b+XRak^Rs=cR`o5T+ip&+O9?XjuFA=VowLZ}p4b zq`pCG#~1Cf+o=82CnkX2_l5L8y)E<3v1X&<&PRcq8DVpl+qN0Q#eUA|tM13dg!j2H zhMFiLk(3s?R9v-W<1?S}o@sG5NbhuQ41d_7FScYaO`=A)8%+P8vi?*0GvPkYZdB}K ziCCK6%P=o>Q5mUFby19G3+(JS7uA~g($J}@#xiO{LJw6V7{2P_*L!j}s~|`>s$f6Z zLBt{xBOS6ozU~;Z$T^wMz}=Xud!S=1IN?>*nkt`GZOWb^g;LYXGkWFOrAJpbtG!aM zcfthk-L0ja?I-P{rUMU7Z5?rXI%`|Elu&Ez>#&=D8@&2%leoF0G_Xc!+9aK{dFDBR zXht~BvWt_N)sr+ffy8kIEd~m5-SBh}-YA6^xK2T#+PE>i-m5qM6Q#bsnHh5m>qtXJ z^_Crpp2y9?ZdZ36wy%Cv+P;!y$yc5rtwtQ~x^_b*Id}B`xc$M&tYEaQ5#!+lH zsXO=h!mn(W=0eE1T-g`Mm;Zw`_}N_98tnOFfo|sP0c^7bHlP8U7oAR0SvpQmw(qO= zAMbxZiPOfy!`sQ;#qn&O-NhDZG|lRC#|EeljA0=lDE{|(HUubfSOYt3+_--JcQ(Jy z(^qv}5X6(vZ?tYQmN@4`JEDBOI8hwg00Fo-TZuy%Oh|IHE-I_VB{@hm z(yG;U*R{zf(eTDxNAMI6CdW{Is&RP{zQ#x}c>%*)hmr2V_jUd|j%umQ{S0>ZAch5r zu(VBw^bB=_M_pzH7BASkgDtRcB^rLwu5M|RfvFeEyFb29c@uBLS>M>jNYBkyZp$?% z)o#-v_XCdHk{)I(^&#oU(M$ZFF}Z>s-o}s?c^M*4dxKIwV(Ijlr$9tu35+?H}A`#zIjqYwD(bL_aOT2`*6}vm%0;o zF#>rcpNxYI$8d_Exs>2p>?vuGT@qe}pA%`m9dpV;4yiRd^YCk5wqX>lLT-st^RyZw zcbZzKZ9&qjd8s3a5^rzoQ0;?+kkpRb`?B}2xyFuDz+s65Lnz&_uW8J0^t;W>r`Uw& z2|4e{$0xL#1~}!HysF51*T6wdwDQ*8E>rnH<)dTt;0WGLdq&+`9x3^&ihFW~Qb)lr zIkwakWQE`MPTmkWs0vnD<+-B)nOUrntJ&|lx4e;A(p4hT}MV~N)djo zvW_$DMcSvVs<_s#BDuR!#9eogK;8ZO$ydaK_U|J>ZRcsX*&ZH+e_MMU+s+QfDXb89 zRVq_39~qTLW9u8B@3KoaSdPzita9gS9eXo-V0Y^MswL`8{+h>e^YQBejGHgEuU3uH zaCfE!bn&kBxILgerXC96e1W}I!nN>ZRq$E)vH!G{cZAX|nMjUn1j^UPMVkffP-~e_ zw$8jVbfEQJoWpO0hcmWIQyaMhn`O80>Y+zCm(%B-ua^lfU`*Giac@R)Dj1LiTo|sI zG(h(c2BHW@hd!}%IceCF7z?e;tFesLLah6=@c$rSn?!{+erfYf^9V@zC9^s@> zv@5)>4<-_^XP(xUwdlHBM3`q{h=(ECaw#R6?h;tiM#kIaHW8nS4f@E@+q>=d+Nez- zaya%hLP~79dOTzskhibZNG5$$b#p!g|8o1?QH6`_4U_YzkKcb zbymaDc3S~Sz{f&>cKyHiwLksXFOOyhzfl3@vVcG=e9T;J%hEP^ z(JR-D&@0d@Ko|@c!AOznQBustP$Fd;e!l@>0U^jG2+JiP%Ox;)$}8Z>Gvdh;V?4pA zXfSCoIaBmNiefdq@rvRO?F9sc8KCL?5odfBI@FBk1oH9mN$tZlLHt@fH(vPeVU&K~ zZHB0Km&>_zEDJ*oq}X-CRUyu$BA#G!`ER?Kl+0+|Tb+&T;wx3%Uy<*Xcjk0dc3?P5 zPjf+)e5iD=J-}9PlRXvtokl(wg8MTgo^}N2TA5l6MVUl3-6OS*vDTyUb&k&_h|pRj z-F%M5Ur8bVxX8P)oSn3BKVC1n$jkn{F6(WR-5S3uUUr(6y9X8i-uTs_>{v@P z3c+GFhvb~Amrz`Bj6y92G)1GCJ99l&ebdxMAkQ@V1?8roeH{!kh zLd$@#PGcR$$UBGw7kJ;++BN@0IGI=CT^IqutOLyq0r|g;;s1kP{SXd^E5zQ`-o?V{ z_!t-mkdfnwjHHg*qj|k~^7kF;U}!M(WKIs#;9FJxSLLi(lvo*$o0x>{Rixjo`LEZC zMmF4EAoc52WmjR>yvDTnjdq5mKZ`Y+(+M4J#BLxsHqNfS-h2g=&Tkf;xShow!vQn93- zuJaB1~ojbw(pOZ+BGe~^7%O-e*6Tr_eW^_Tr$1dJ&8t7uFHVE3Cq zGx+c8lK(6x_^oRw@DzX@+>X4z*DdAaDsbAkvE+7dgpKrVpvK&|;CT6pN2I(`@Wy_$v~Z-^GMgEhwEi)hL%cKiCfg?X{nB{m$(m5@&#xX|A(}kQDAso_a{Fp-%yM1 z&f${mBfjBuStE$PeQ^?bb61E}t7d!k(|%j%wk)ATXoQb)=6Vapr5E1Q1S$tIDT(MM z6zBvjIsT(w-lQGw2shnENZB~t5U#mJgH>Jd-2@X^t?x-8Ulg!^h->V0XH8DACL2i& z$IG+)UD6S9hu!uLD+8k`qoSGJV#6WP4j{P zKMFwmqyE#C@!=*`a;4d|BZYN&8rsA%ndnE4zFuO9Jvch@WA z%Gj8o-b1I`1qnP#&v>7ZbX_>(li<33ZT%xy2mq@Ev_I;T&H+9nQotwu!o4)V^aFX& zMoT6fIa(Rw^H%`!?Uy^4DxQQW2Lz}co&cX)Icagu=GdG zZo~;7?Cw_Vn;GRXadzX&`Z4m7h*>lxYG}(FK~@|GO#uR2A&* zSMa%^4Ai5G-e?u3$RFDxtf1Gx?Okq7Fp-}5+_+m6ZXf){P(=MbY8M{;rI8$Tjy4Es zL>`7tC~C>Kc(oo~lENX*%_5JwFhS}D<1^Dk1|&xM#boptm=-tSV+{VJ`T)WK!#Dk% z&y`{mDqKQR+JbgIl1=7J#g2-&`kw(>e(+zxfQtGzOmdVjHEc+C_3bCo(wZ0j{ zT#XCZL>{`f?{BA!+$vK4y7h2aKL?3DQ2I$L`@`g@$Zy}|u6IJQ^Y4qb-^AQ7zxa@; z{A~{MCy{H2@AwTSS|XAjp?e44^Ost%yBcjd7L@uyhj zeDK1@wVg;NvBti1yiPji5xSPswmpR`2fMlKT1)T0ZjNsA;R7Ov`bF<$pY4HXA84Ik zf6Hwoet}hOd>PbXN@db^H?M#0qrznS!OhO+3-8Pc*F7*h$%jg{1oBwp?)suPr(yUg zH=QYFz`1`YH9>O`a0Fri_ZELrwf@5WPhI-SKK=CELo8E7-iPQk1hS8c{O)+xk1-nX zN`%G-)s*q5r0CgSdO76Z{OK_3QYGhupq$6=)jm{J`d%Kf*S{CKr$%_mZa+FI#fFCQ zIobGB{Gx~0=;Cq+<2!eh_t;2YWbDe-QqF4vNFvC3W#%of*YNE^<8DZ`o5#utE=t+k zC*!bKb3e|jhzA5PEAtT1)x9#v$2_=uZH)Wrs-|bhD$}u*+danO7u!=DB~G}nW`dP7P-nrXXAncW{+?0;;rX#fz%U}0%=nzIXfMx0AJ6uO0TvdiNESM7_t}Qv3RVx zggs&rXqavGi~MR64nxaPR7X)X1cX3fkB#1+TnKz8pZ7cafNY-_IJ-^?5ga`>C2c>UV&+G|x)-AYf*;oRaCWLx+hwsX z^@&K?W**6DOO{NQu?kFkUeCBgOgJ|dEHwO4u&rCvp81O9+LgDdS_Z-oX2{n-X1kOE zdRneh-8WrGa`s!do(sNY;zT2<3Tm3gFh0al3Atxfxs?7vZ`lF4tA`gacU*+u*nm3cDWxJ;p%WL7>Rmv_sx3gYpwogNPV<@=3!x8 z-()9CNMo<}R~{&4VXCLxt*=v? z&-HY5^K+rXL1?Wu=k-$f`mojuf;Nw{A4LBSyZy+yyU*a-H}mI%I&UD#rXw; z4~j$FWEMgWijr68ExdK6y5<7~Bf0XR>W3AIB1U|SiuJjV z5=qmPt}XFly(Z*v9~kl_)0e!YRs3K$U!Gq5PAg!s8|JFmPbEPHJGrxa;vmyu|h_K6+#FmF$^7*()zx z0@yVTH{G`)F+~Om@^f$ZwiyLl)67-d;|R%(p-v_A$0&RdIiQbWx&>yAtjGRP-t|7Q z^U|XmI<($q^!SbekBb&&i_nofB~gsl1=Ib)@{J%=5AHwFRiC0%C?GJoG}e()cgH!2 zX@H8qOW(nisfpAuT2ZECukd2rXAr?ufw`<5iI8to#;dvrp!}j9zh@D3Yi{oYb27h2 zkSSzXac$K*5mr*dwFBSEr|I^YdIeiSIEEp9R@!v{hkJ8Ra4Y}KQWvPBr z!HQz)@OMPM2en$fef2e@@Co9KF>XinYrElnw@Rf)RWGc0KbeqnF-F69Of&bo-am=- z9v8YTPvq4T?m27NcT_pt=JkQg?nS%_K}qG?q{kY{1uri7m$>f;?A>)eTB~(zf3o6s zZ>E~GN**n%3GEe>ls`w$Kc28nff?3<{p3#PU6kp}Mdpp0xC@I2Ht8{s7Lstf=a@-j zaVxWWau*{HU3gdJI=6N}SA4`XDHc=FI%Mm8(=*l8m$_3{A%&h?CNKjvGKuNgQM4lC!I`xjrZB_ljyojLaGZ;dzOG}B7Y z=X23*Un;O$iC^Kqm-Q+_1eA8 zh07fgjq%a}XiXB0GzTP@@|Mvm^MpJzlkA)q(W6}SuRI&xK}$gOCGIlKTV(So)~0z@xvT4|PM@;D zxooc(^oYXdt6P<)LRvW{E9!ETzo;CJv_Dl{+|=9JpcV+u0xb3tinmuDl0Vwrc#`Yvj6WK~+~QP5 z5yTj~D<`(+(y~EZH#bVhZ$j5jc4Rr=|DmGcaMQ@{vx+CiRb0V^UTUF)uwK&Q*#$T1i$ySn9y?KF$SS`hn?4BP%1vt z^jM00a=VS(luJ`?Ol>=EQnzPSCpfy8dKcxEv+(?3#8gD-ot;>v+fMT9dzdMc{ULTW zA#=q|?7EL(R>#kMg$zdhDwTvY_FgJ*$;So;%3PlC3!I6`JwCI-Jy|btIBiD*xq3U$ z{%Fo(1MKpL{U~0Z)GR4uRB_rtKt(LGO)C|jSnz%*^2>Wjd6zWVR>eMRYwGy510uL^>{;TlOL0$wm(jr%O{O^4xMaz+mD{*@BC$AfzVy z)Yit&k3uKWkWg^sjUUmE6Xu5H-B~{**6!`)M4cEAzHjw#&hM%9iZH1Xiajj@cUR!A zybaC)Muo#jA~649pqc&23fMUgey&7ZNn-vL^aRoRuio^s*8Evi{WgL{uz_sHdMk&}R_jhBc-3e-_A3yK9QWp97WX zRGMcot~^EtI9aV@36efKvzT+nW;dKCTnP|8Q3`k!>A&8^`Ol>fI}3>QnL4TVEKn`d zx`~*#74w|Hj{(^jIj`$bD=hg?>@z`FVoYy?Q`r3BTb;1M`C-~HNV%Pgga+b6l5BEx zgfp58&!Z5!AEh5ql&NsoaPJ}(p>*N{VqKr6Oyd|a^d=@gF_MlFzs=w|NnUDw!?1A_S zPN`*&+$+%}%GA3T%rFw4g%xGJqpF!SM8hmQg0=lFg|1$5wM-$0e$cfC<8j50=^j~oiS=E-UD%7r-Q?TC?N`UN$tGNh`dO+uIs4KE~=(mH;t*{4UxGs{4QKN zH(VIuponIVb=5Xt^rHcF8i8ndmp4=G^;S(R2qB@emHYDb8FwW~YwA`$flCBxBGp)Q zK8v&{e3Hiz{w>yzh-HsC^jdJ#t0U18uSr){xy7dWApc17u6DJcAdV%Sdh2bEfwC;Y z_v}G2oK%`o^F1vN-Y)hX*Kb%gmEpX^stZW=@G}X^`Y0mGp8e=I_o){ms^K_IGx}9f!!_IUOZ=S|+){BG78GEao=qyK z=q*Wi&o^)LG!X{;$h~?6-7QpiTdeAa37#Q)x9YD<=QH$Hy^ZllPW-gGeeebI^@G(< z%L<2**O!vMvxMD#X(u;J{B+3VN9He*J4)a;}hbl>yEAbfe#H9O=gtT-ZQX zPKZZ!;GSooPr~bvRU3@bFV?X+v(;Nf?1cdztTpJZ%vCZnaimFEZ7Jff1Lp9MRm4Gi zdly7`ACd{VhhnR0h}eWoFggJxy@;It@!6^fM8%V9_s->b1U61C#0Uu=4Ib>N+k1B{ zg(G~qMG(YznsU?zUYaQcyTn%TZ9xX7oe)>ct<0NjHk{c^O&=axU0Th|)LcxElcq(L z=`h2*exaj>#YQ#um3CmoPJImtHG$HwP<>NA;w#BwvQ}R1PgCpC!c%M^YyJGnxai*u zbbI`yF>_-ESV!t?mJ2N7W}6GqTU8G31{Qmk#Fa!-$|g4@nQ*VL=hvz#4H}r#J-VVY z=ryi*#IAuJs(dRo@?nJ9Lnq=@>h2nntzpZf=I1Co+0lXtvQgd2p2XSse6qKd_!5+g zo%%~3mEZ|rzlqYG^s`w^h~&A#%6?HjM3j75FImJo$Dr)_#YitpcZ?BF-G1Y0@>r1< zLlYf7AD*XUXP|x?w$Ih$DyhM5#@pXVCtt|UBhA=K36pH*Nb^$gs&u&a)xF%*mg&uA z!E(pA`^NgFe19eRC6l}g_NFIR`rCcOR>*hAwfYQe@~CYz<3|bX{10C^S!Q*TyoejQ z^={~eL<&|xzuv3;u`EwQV{H*X9hBNNC)ZaLrqZtk*$EigR2L7V+j5`F@;g{&r6MPD zHR4@Q+IHcVGI%q*aU3|2^BPtzari1`u^Z%cSDkt&E@-Ye!Fo+^|Q- z8!wg{lN#x*^k=*`S1vr>-!-`@?(NAc^}bBjB?I@xTKkUJ+dL*N9+P(~hn0eY&Nkr` zd|w!<>#~8Z&e!BZ^11Z&D-&k-M0gR;hD~@bAxK7g{Q(d*)d1zz`IAuyc(nCbHg$5J z-XpFao|n7{az@BHja9ZAo=CUM%oE4`zwX3rN&;MG0Q zUuGHRY4?8hEfk!c=e*cqVNZ@|fqHFL^dbmt0U;(KM=Ix{%-u<>!{LUhgBupPlm~cz znL_EVuvC*J`qqR`g&oN+KzHK{!IhTcS0kovt0huMAaO6Ks1aA2P3gBMFRc<#*7L2Z zZ^wme!f13hZkPa1VBB|}egbT0tqs{Ob!cqz^$!>z|3y+c=CM)|$|x`V#uva5g2taD z$;swd?Qj9{OyeRZ$#aq zM%f>fnV-1+bpK|fK-eJ1D$RhbL(f=xhb2chTX)8*=5?h$PNLx0fg6oJ+x(;yB1=Jm zq3uVVbV`$P>1tgoRr~A(1B7BXm9nSU-e)uM+y`%fDSSsPLEbqpQ^m($nHccSjy=p_ zGr0uytfOI3mgykvka6^IVjT<637;*I>5SpkK#@_L4bfhP$v^vwJ6B_lCPrgx`TVXo zizDsW5m&v!ihZl}X1M1^6f!PuoO?1`I9)zCTVk>Iz+!0?Tx0R>MOdD`XqS~dV)4G#62E>jM zq&vkB38~54U67&8{g(Z3Y+uV8`3G%IwX(H^TU*;AT-%A+sB6KtyZCS9HQDD4^Q#aa zJCyPaD|j5)-B_yjQ%~>j0yQUCi#`*gs!8AQr^GgwnTfIPPAuODGTdk*+3yzFKzh0; znSbfMpPx;d4c1}71q$)_o`e`Q*PFs$WN&%E3Ta+*ZSBc_La2=8^i6d(j41rsAl&r3MmAQvr6N{l63%mtY4Bzcw zQ~m()p1bp|QmNDh_5r|GNPWuMN@~}7d(T-f2EwrtmALyZ zutygGcqR_GV*$AD#_sYhhTve`HSN^#zHQHI_?3Ot=9;!Ot8hii?F3_xj_Q%xh?|6Pn z@jRk)yZGRcqQ^|%qytbof%ZrJ?CDP#{z?zvy2KI3gW1MS6uNs9MMo)OSd<~_uBGw( zg)*8_1TMMLR=JP#w_V1(A$PC0o$_~m!8(_~M!B~{1gTKQYd4&-M`8&}(7l<6gPBT= zOw{y*-G>X;z8F*XImHU$7(Kq_Y2%C${k*8CPw3^eHlEwfB*tLL3%QudFY|Ibvyw`# z@36JEew~WhC%!zMgtd=r7xPdIi38z z;}24P%IK6Ays%xF1CvoBFc#`(#ZpzO_+qh{zipl*p1m z!GZT3_>G(1ip0TmrDP^*b&&Z7R+FDu^e}-rAjw^+Rd9Np_vjYE~d%kLn%S#dT2(8T`{`Iu={)daIr3a70JJ^O%z^gDWqJzyr%bh(IavTl zsRKC5io;iCVX<0gWVmAM`vGKurOpMEZZyq5d#azF+-7%HUyuF5jn>UeX(lyvoU*Zq@ym_Lvp3q9Zxmpm z+!wM%RVjEAr?_fT)fwu8H58s^7sN3j%v9?F{Fn}_?WOEifd>APvi-GZZ#M7~E_|!x zb<0H0O!&ZItp_Ut|+H`rE8}AXZ%K&rwWi=`% zncW?={Bf5E?K^z^>W!9L9qK|lGq$K=P^eYWSK>?jD*m9Xc5z1ngf#JtdxM*RM7Q0Ml=`5^sCugV-h;e{9L-uNcAs0% zJnar=$Ltc8B_+TPInea~Xx#hmzxcmv3y_>&KvV@X8J!4CRv-*VYHBg}=`(lhGjl3k z?bVw<8<63^=m$XIRB$y0n)&~Q8lM6?BQ`)k{srICS%9K!TL!(@FA1XnaD>2hHo*HI z_YwkT@I8O<-$wPc0De#!c0#0c3=e!?uKaH1JX^0kq9DCX>lg!v3ri?TVs&07m7+A( z1+J$@yMAmG{h@KCOFnMmGCP%sF--ib4~wkK@{o2&Zgm?#+{+dnLy%yW3@&AMV*To3 z*GxJl#cwigMQ9ms8@bH~lE`Rr79DMEQ_Wo!8sOFx*gR4nL z*ypWGx=(rJ7Qg})z=qzRw6fD@5`Lyma9?j4CrSX{o9uVrQjzFAztCZSqWhd#5gvx! zGx0?1(CjV03CivaMK$OPg0jzXlf05sV~i3)FtTI`_WH7j35jQ3rfyPhbO(a1npdls zl`Dx<3*?!!K6zi?lrdlnm@L6;Fms$oJup;#L2K2sWBVeYgOKqJO{X2MP+q>U7f0Af z0{ucKzcagM;QIRT4HhQ+P80_~z#m-~oFm|;x|+t-;r9*3ju$Gegc8 zn=TqM|Dkxjrxa$&%B#HzG5<6^;=q@n(*Ql*4bwm7hn$C4U^OkM#6|I ze-cc`&yjiuq?wria5IuMP2$Rdj9uN^Hv?#W0$KAY2UFLS7chucsgoLe2pJzs_?2Cv z2qxuute{e2E3CTwx#LU?0M0{U$jqQDzyo}f<{#Z_{GEp%LI1>`M5_;LUyEYV9Mx8d zW6_LSDk|44(wUD^AlB80($(mD$)&8z+^wX`&8ecvtbVos>MJ(QE_OYoZZ%a^4n+4B zquAuX1kbm%B+K#uavh-k(R*p<(EpU;X{`9`EWS@;37Ciee=-kH`nh@FvPT-NlF9^i z0*^n|0!yoF|3AzT{)Eu42ZrFE&iuAX*7v6%Rhun~y4(m#2LR!SOk%LMIt9s_S4xAOb03B% zv_BDOeB9_<_Z37~r_eBL4yN${J511-jM?O^rL4qm8R}eb#3RnMV;F9W#$6?StXs5V zO4*j@Z;7nZT4TD9w)f-mTqFh4d(F|hfBdS;z-SA@+R!o_SZ6+V!cicd* z8rQ92;NaND^9&ITka@(Su*pnC&$#F~W1wTi0s&nW5Fxfqw!`U3d@j9_&N$>Sbld5i1*Ox$@^_VLk~ zhyiG-^06Lf;>=Y+GUWV&EI~e;?>l6uXj_0niTcoD z%oEJ7@(p>k>>vkkj+Z@lu{5$&SMo?SW-J!nD*aeF)XHeS_=ur>S>tadXgaEP*m+~F zr^!FVuVK}=l6jAYc&&l1O}&>njZ+Qvp@Q1CY#P&-wg%YQZnU`0InA@Q*yW#4GN;?tw3;^es$EiK90Wl3CXx5E-i#TmovY~nCfaI2TGXg80Z zoAVr(+pzh&dhmAmwLGtLSG1;Yky=d(x0t{G6#Gu_G{*5DjjyO+XC#z*PMiI`F?y|t zSlJ!zggZ(oq5{IhyqRxC7b>pChRl%G9xpgi?O$v*)>ifs;_68QqZuy39$X+UMZ4LQ zwqc7vFo(FJF%)vILigZW#Bmsj;0tILZj*e6NW4|FU0NmCGU?0e&|Wc{1k=cBV#0*a z>A1>bGc{wBtxHRh2MqDIXS;aQjckI1cZl9ZT_(ZNatRjOyRFvgxJHgqrm zN8b@9@O9?t#vLX{iIj=YDFg>;6nfvuCo=mJHtQ*9_AzNLG57;X4 z`7+dNGX*xy_FBtcs|gRa8f&(YDIqs4@GbCUQfV0nh(8dN3=ctlL|rEwBMtc=p+>Cp zlq!L|A-&gpT23QbO^T_W++a=$cmHW+(mSaOS87nxCbfGd>B1??LS}>wsVHzSCvQ&h znCLR1U(XDMsP)>DwUOU%nPAC4YL_=SDuH5LY}QaHs~N8!#u_zVWMIh{)*#aCuSb-I zxaLvP&aH4;(+NpV_X*rLz0g5d!rNH%c`$^Rw)Y(#%ZTs0LLOXt^2Y`VdHQx*Lb)$n z%38CtQFA0U<**G{SoojLI@)~}m%^9M{w$HZ@yv!kTJdZABgSiQ_z&l=Rm&eIJcCI# zvyN&hbFJK2+7bPg$dK^)pL?Vo_TT57C%**sn;&L^Kg|w*Kmu4aoc?&z`A;Wa_2%u;dOj$^R`d2ROc8>o;vJE#L{y<@pl9YF$<(4%WVY?LkfM z%KxvovjD3)i}v=RrKD53JC*KIQo1_?q(NyxQc6JSlgL*YA)GjfQz z_s+sDLPD?C4Nt@Gp7Wr3*nz#oy{!qqXb1>OJulX>xXDB2-!icnj0# zfV0&gitYiMAJiQ(@3#O=-B_u|m8W66mJ^e#3{bG%p9o*(AAO8F(8Er(M#+0`<1yDm zG+i4aI<@E|P<5#F#NM}bPIaI^M%+=5o^Ac>VNoeKmKfg-z`x#vO+b-o^_5)CXkqah zJZsPc=hzIEJ9kXB+QK(X$znXE7?yEgIbm zl%{d^s@BX>be^*!|A^}ttA3ltBR3~^pG=Bw_8k8^-rF7}CCx*wI>jm;XCE{yF(cXV zSKgjhSC46wD(w5i_!#r4eN5`f4c5}Y*16Rr7PZtj{OXLtH4AqZa|eaFL4}fyQ_Pmk ztfx*l)9EzYWEa5@BXy@rwq-HL!-ZGch?sDMGERiyGy;tZ$B3| zsF9<4iOuaVqvN?t1)>W+mV?@K6Wa=e!G%!Z5JOhX|eag9@WDAykeNowP<;Kf) z=kJ)sYPdb+duCaX@;q9BL>8hnqN>hc!?p2U%AFk>)7sp?ozggdUHkFx_HOp$P<%AF z>@$|S(5*QmZ(u_*0vq?hC*tXikN=R95LZhz)E-s6g<_>H>9(s|4{s=m4CgW$GeD_JTE8VZBW zqgJ!7j~D<7bV;hWLTds=^Z>D=XZV;di}f0dDlMvlv(+q2Yis(H2t#rrVzFI*GAz6a zrMmDz{uPO2Tp{xOpQtm2U}y&9gxI{9$iu>EY|>EB$~>&Fr>S?zrY$J4?LQiG31v!C z;eL+gmCp;m!_Qzt0j9ycg%AG{JM&EfL?xz9>#S1RzCi86qyQt|0A+JF;f&io`$g74 zcha6lua>E*)gzLu>Ii&VHVNqcp{cvn2u!nZORU7cnCGg;&SGVRg!I+zNXIxFPLhvAnIoyoi(Xw22L{u)icT zw|#&phS7)hbIKq$C~n++6f}YoqicneGgF#^sTj`rl*e8bVjXn=t3PuN{forYAlUez zW?l%FG2>BnS)~KpqtDKFnYF<6tKcLGKHkbHR5RrcvYp${e%%pNJumXIH!%|N4r+b5 z(L5$$S~Lf^m3f{JWRF>M4cj4A+lxDp@znKT(8Xyj&}886#>P~}RAsuU85B-CI*Y?T zEwRg@3z|3K@cF0rMq41Vjx~()FQeu}KD>oj_tFGJLJy7A4uCJLEYv7AA=00%Y zl8LKBmqWJ8?&`N&*vY+yoA|_MvXUl2sTd+{#Zld!7#y=Y(%qN+6u;Cs);V^N(NUVC;iC;8($GIDN9WIKBaWyoW7`fA`Gq=eplX1y2RPzb>~>{}r@mosPHWAR92 zZ2@PTz2;*QTaZ)e#D=+39#BSWQNK*%jn$Y_F5be?loEwGzdO!e^-8zD`*h4>yRC(4 zY59Do`R@;P*Q6=WtVGziE!fhn7pXr;A}c$vBi@s&nWGu>4x+|hh;3pfmq~9S_`0GD zz`@*)3*#?%aY|@0dvJ2c{2?2;PT0Fw#6l&B9o~4^_p6mPZ(X= z7Rz4E9n0Gz9@)Dr^*L!GjIddQmu7Zq25#|wn%t3Iw{8iP;ti~Yq*9Rwh%cO|WVc~s` z&eU=>kMX0%(X2msG6$C4v*GZyTm4E;T?H@880gW2h4+T}jBzirsm;b;PfIpIGKWkl zB5Mdr?z4FB6W&1j7e{GoPZAR27ff|XC{S{}KTsO*FcF(&q~RPe$60?GXy4(Ruc0i9s(<5}M|RAytXI2B9l{7XN$;4}UKg}T=_|vs3bU7YHkcq7!_V-emfRIm z%wyk>R7cumDD7JOXGpyd0X>^{hF|x6IdV2ycRlSFF{%jQj*L-``2l+U_^Q!^e zA7Qfpe2?j8f{VZAKv!4G8!>WL6HLhMGp`PBQwFrK`NQn{jlg82Aif-eWl=&C?jXBg zy!ye^+(a&Xi!Y7?QYdNk{R5W=WT6YCjGuSTu-e6I?bBsxx(Eg6JiLj=B}^bv`IMGD zPz5+s@$`g+B;K-!1vEef9Un9|W+C+}=2Jbao`>cfAkV_EY{bw+v8cwst(PM73*$YEhx53z*3;gE(tClFA+f4QkGB}um?=fk z1SgE^x_j`x3s?}BM1;muhzHI&EWOR=Erc+ch@OC-vp^!1WDG_c7Z~z_1hcg=4$v;h zWZj6)B*x#D_KIG8Lf&fWfCJ}l*_V`k(jUytyfz;Ew(4Pf_LfiI)GGt>JPnO7yZmz0 z7+P>X!Qm&tJE_x|8hKTjMrb|5EynkpV{e63J!yF^H9zxqXW7<&&cD7}ypx-!SGw-h zabC;Udo4Sp?_LpB>?&Q3u&^^3^yf``j%Zh}<)uEGWA>SodZK`yGfBMWd%JB5i3Q>- zM%^5V7>8Y%`$?Va_ageMn9;?bxtA6l1eS#JCn!x6mbs^Vr$RZ~&#oUjb+v2?$k;9=BK zvYpCqkHEME*%M*lH@BP;PBs;*g3z%zVO}EKM6RSLIpxRTW7H4n2u^NAP2`NL38mQh z;yy#7({?O)sJA&hfu(M$v3T{-;Uf`#ERr17EgTjkAz9iTH_{iDYDGe#W}<84>RXh^ z9$=-e=8S?Z4Ec6A^m&@<>iL+1^>C4Jkvo!;*0a0qwZtM7UxLGHV!}!TrAsE(S0{|e z;$KsH!llBcRu*!SZyUndn=HMOdvEsjs|qm^4h_#Y2F1efAXfwtfy*ZJ&RmBB;P&c1 z3;^(BWBs3Q^LIRKDSaUfgA#G|DqiK2y^w{Fw%B!K5tc!0vmX#Be zrX7K`FqfFlMFdD-da~EgOVQ{*YZ2B&j?WeLv7ru8yO)Fy$AylJ0C$?Ao};)F%H#}J zQ1nQDFe^67rQ{yZ1`<3K`4dfOx7$bbRE-s$Ro$+yI@X!`>I=aRgsZ;mEBP4NKQXPS zktm2PeNxe5SwJl`9>qbiV&-VgC>T0c;CLE+$d5~Zv z)MGcmMlg%kv!TRFe{`2?JQC+=QNRiDZOr4oXcG!v=I1Gm?#bPbi3Z;Tw)*K~Q0q2( zM%?(mD-zL~o*tt%KshHd11?ogv{NDQ+zgmbO`b3W2q*e$EEIAjsap3RqEhE0Qrs_QYw-NT|u_1p94dbv#z zBLyA<)8dGoyqM=hXIGA|oAHEZy_L(4gj<8anZ3>ODdEW~7uvXc=~m1Rp@T0tMzH(z z`!kSO2o+#Qzh-UHLI|8hStI_~#Q(?1J}yt9E^Y7qweF4j<3<8d$L8CM#@_7E<_cb% z{m21d%hEDtIwJ?z0A3jp!|~$9X~?;=k8*VFgyR&lxXva|iqmmwSqXX}Z0n<#+Va#HVRu1IZ-Kp>@VYM^PqUz~=`eke-VHCwsc~!Q z1I02ef@OmZ7X^QCimGzTBf~7JR64BHS*_^sE)_I@A|7laFy4|PMBKivZ5q*}8V-kC zq)RY94v-EXDhc-RX*jV@CmQyL!)8&u^;k8+;$mr3vq`W#VMYbBzJkt#-p>9Bd_LF1NRFQtd=d zDUNQ!B^q5t%3H7dW;Q(@J1|f9KLcKFi86?(KaG}p{rrHDc85N#` zW3ai$27SjmpL+NK`@F)EBD9_#`}e?jzaJ4gzuD(q-Ll)H zE(p8H>3Xbo!-J0DgAqwB5~LK}1^H!&O=l-E6?oizL;aivM1r1aCj%>aIt)z(JAy+} zEH?08@gBs!R)T)fpw>c$DA?8jY3$j=D~^LA503+d(rn_m=#omz!&If4!jgWV2#E92 z9Kh(&Cx-3ndq&vC(kja0r+}9zq2i@RwP|Ik+CMsC$0k02O_ND3cC^< z2+-=XGE`$==H<|VuQ?*rGs_4O_#$aUrxb$u2++8idGQ4c$54CcsRBe76)W?z=KV^| z^KEmuu7Pm}()!aXEM$Awom1HHv9p5&W zgQJT9QJa6DaPKvlqPNcjUV>aa{6LzL3=52|dyn$hZ$t0g4W@90d{$OJes{jDbllNB zA;MxtL2B050OwBSql`t|kf0%2@LI1rw!X<~En{Bo0OW@cS+civ`e%npc+ApCVY*n4 zF&&8G`c2<0Zmp!1;ah&r;H^KJHI7I12+`hear2~AIDUvX5f9JDEX*{#~;3&XUvuRrZY+v7%sZ{ z{a%h_MOX6p)1(>nDw(0{VA=aO_hZPTQoGLJ#s|J!)Xa#-$6{VR?-65_O~2r$>|^cb+}jm^!n3H7eRofhf?Lx66{M zCf&^RMj-7Q*r~TxI<88X{2f-S)d`l_Qx3w~65qC1{~`sIATUwCwdm3#L(fLf+EHp# zT+JS-(mFnVI**=o9MtlA9e7#_m_|yWQHr|pZ-RZJ-Vk%$(R}G^41tU$u`)_7;xGD+ zpOZbPu`{aC!H;B5T){Wz1R3$=0#d4A?jy~x5fOIDCevV<^v>R}FZQbQ(jNEqn(SI# zSp_R0s9_!h9s~H;0mR3SZq8gBtXV?6CD0@~2)V1YlEKOEzv9|Q8SI;Ym7)=N!)mi5 zRNxll7Q2UhNc&1btT@W^$Y)P84d2{f*;!db-6uAaw4BEAC|w!j{T2gJWo$(PPkT^C zLLe)wcoY?Ia)qo*l7O}RWllN?ZyrF;SS0?anA*c*|ByvDXRQ)8in$lT$_FQMBzGHG zrz|Ula}cF_)}bzw!%|JmK zCVg}ey`~fW8y#65=b?_Zb(|9`L-3Bzo92?uBYbtl7p>Khi$^AncEoON$m_T_!bDH*>~~awJGbiWbbJ%$Gp3sx6oqmKz(;D&%OEehiz{ zL;xjOz&3O&{!xFrYU82B?Qm7=%+CWpg+lkmm+bID1niJwjtQb^RFfpyV(!n~K`e%G z6^GCzKn|VHR6>d}aa(Ej*%(_Cd8_x%VU1wuNGZeRn7HmC@0g-!F1yxFi}ltBU7VEs6teb8GnkXSM(^> zRxgM!qWyqCLVtVLMIQe%Z*>e%*+7#wqK^x;f}Equ8-{bNUBF2oMDBCRcu<#T-S^WT z+8*wT<%u#)1Z&R4a7S#DL5eSVo7}r)o+tAHuLB0#pVRIB*d^o^c<-$)(k+ z*dSQVF4fO1J3I2?y1H?DFE`J2e>rXj93s%d(>DnPI%?{(ZykkqIPwnBzd%DR$~KTw zP@JECB}?__R&2J~e;HAsF0z*0WEj0dcG`I; zf|RO2K}#0L8uF!%diXm7#-!AnhtqDJTAvqntKeJeCB$9BTkqp|FL%?6Am1rVp?kT% zI6T=;%9=|RzO=#AH^e*-8Subpzb5ytg^~Gp!&NZ9HI`QI%s^>YBDf$_4zRbr!0${+ z%}Rz(&M!#DN(Z1mCl@ppG;YEgsN8WVL|WW@`ilE)3j|RjWQ>_qt0~qeRjDz>CR>;& zu3K9fBGQERqTL=N`pe=@Xg%%egYkj!d*V}H{SmUf=za2VJ2{nDn>c8MrpWcwRs0`Q ziR_Wu#O@MptO<=^itZ=GcR5EORn~&NAmzJPIwUiRrVb+(iI~f8R?C>TyC$sLrT323 ze>m16DZ^rR-7#TLV5HXqjnWds%=V$=z^cc=!^}#R+m-{NCoG-$u+zh~JR4tDaXuE4 zvBPSoLvFDzIh=r7q?3u0WT<;Ol#{lSa!fB*@3fBDb?!*uVVX~knqx6qRxcAottc71 zRnHlth3|AGa!Z8O@v`x>ViqEW_&U; zU@OK~J;ePecLEv!*aL1v{)>E+muEGXPx$}pr{aNnpKQp_`5A$N|BckLx~g0)twoIj z{0L@6P-er)d$I`PL<6W6r4dvSY4g~gz-bM-#ab)l({J*b8M1dP9C_q3T^uQ66@|X_ z8wv;xFjAwThZEA!jIMO9z*3?_z<#A3a6uKyOob0X8()E)We(GoLxoQ_3OG*a3-RgT zMG4v!8u=P3t1~zYuAZ;{itxT%52eH&ads0y=Uqhw(`V>!Y^STnRi^Q>IN)ONfN34X z{Bd0*ipW|d1ByjEf*#zFLJ`S|@Ci~llxqLr&yFpfEk=MqZsrN@4w1`B4v z7KSn*%_~p>X;1LA_jUui5mKT0Qpa2*VcM&rFEmGm){3gc17`=j_>dYD>;nP zBwMt^ZpY-8=R^=3i)6!MOhT{6sFNCt=cJiF+jPp$Q*Ss9HML3737D_39M6Vtp+?%x z-=*kd;`U;X@-BIFjAuf%VlV=gH&SgX?I=ycdyZf$te`wsczDvkwN<^8nDQW|sJC-lOgO_FPaCZSML}4A6>_Ot zvDaW60_Kg^R$Q|&|5juZi#wEoc2^7`%t-1`B_0LIe)dQ!u6SSy1_XV^QS(S?+Pcm1 zN|r-hMW4xd;UF(HtjNH6JvTHSFI4O`-FUj8%h-FQ_$`N_?6)+BN7_dp9uE*k{LZRS5gqWdC7{?~NppvNK-X575 zWk}Rz-?QRgPpmW9eIe6{dRI``;0r~-9F#6&F__;MdlLvuXa5v__+!`zJ$Bi{)*2V} zzWhqzo#Sr=SfWOO_0|+Km7VUkKmOI|`*gxqb*KBla$6^%^NlU4Gm&T@0YVfnt_0g` zUcaljO{0J@I2c1DDNcX5>q>JtB6ZK|MNWxkin(m+n|~zjQ)=ETf?$qEJKKJ*s?t;!PXLSnrZ^ zW>3YKVTHwa*-gmF%>I1bR=cW*+f$?v4&0v@8upDKCPS%dkO!cq>LAq?FgE}}SoOin zkriEE!9&aAJ|2o3HH)5>Q7kRT3)Mt;Rac#A@8ov|6EHU3w_DZgRdvlT98=tbg_lDK zM)G9JHw%7ja`>Gh@f)^I;#lsx%6#oxrFxbxa4VM8-xt;e_E=T~H>BIQV-c58&Qw$+ zj7vLCQx#4kmduDMs~Egbf7*U)W3y}tEI@WsHSl0e$J;Sv>|VC zf0?h1U(10=loX52R3@lpZ|<&m=9ae1K(#$C*LS?IhSURM}j%oA`24 zU2W%%n)YTbgt!;%^6zYhUWQr5 zPi=EJ`K2zj;EwvVJMB&TfDL7t9BueyQl5dR0mu}&saxBQIvxR!6a;}0P7=Sry#^AL zmJmMqcv1k_ck6)Kw%sfib_NljnbnHSpv030(V?eSzV1=f*!us#rSCveXh8~ zQ)2%Z_d3q?qR-xubkT}Y$Z>ckF9nvM6w1TWq~Iby!PR>T`PqdPF%EuvT-Q}FH*6(p zrhv>5ETKX)j7lOtB(LqQ`03U}hac}7ALJMW9c&m*OSo1Bxbi?Wk_cG!eUjPSky$5c zwU^1L4gG>iuX{dyBC{y^{LB=+kVS=MK&?}Sn1c+lJtYTnEqzPJ{j5? zb`hIv9nxWv)zk=cETPIivU|@o7`*(a(#_Oqn>1G=0SaxHI8yJP3^#}@$_?=`7wlu~ zhxD*WrM4+pFfx7;MSQq28PFg;t0nCOOQ>f*@VF(bscyV|vwdgkHeDQkwDtN9k&wfH zWl|V}Nf4qVd~mcOm%cHMe1ECu!LZRu+;}pyJ%;dN%k#MR8gHcB+}AT6kn+`@Q)i|8B{J!pO zbxi-JyTH?@m8yp-W2cN+GzTBw-(wWL_lEx4o0-oh^Vjo`q|xerFP+G&~&YZDrE@9Q*rvRKo?q_`jd`E(5cTvtwT z)hK)cHZVq@T#C%^hh>}x`~4Y72Yl-dKED6nIHJw7 zTPci4PEHn6Xk#vDQPWKw`f0CbL16fCpN_Q))H`)3@u2MTPo1wbSfHp{8~QW4$;+u( zu$3Vhu}t4u4Cet)6vmZ!RU`FKH-(P%?QB?eA(~_!2W)J|4zqTuxH)TwXMUYJZ44!P zG)*Gsp#q0+u#KnB_@MK4kp%6B$LTP=qyrVCv$(z$A9mSmqWI}w%P#W7jlm4&4HPpI zy98hh5P#K~6(SIgCY;5`N=I_cl6J3k+4m5L99UVKAy<5vC@wmBdn6U%Fhqy2ZP;a? zGNg|G-FKE_F!hIT)@zudEd?Haw_51LXOeejIX-1d3=$A&>-p%hPCF$L6ESx77L2bF zaiIF>OWP=%<7?g9+zM|x;EKL;v&MJ88Iyi<7aMp&-SZ-DE*hoa%mi}c$paMKw6rc9 zto_dxtr&>|ctzvj@f$W3_s0mT&Atvo7b~<*S0ZtbF;A=L_<>_o%seaD0ns@t2kvq{ zT#3cj0Ui)|!vDy?@Y``e=M4-rM)YUwkFv&(6H+&%PyBd80?Da9_Un4SJm$G-%_Wid ze3^OB&`-!vA{dJo*#r;kx2P%>Bqv_KT+&14{SevbP-pjwFV(LK$vhZ&fn|}|^NCN3 zNYiNRi@=a+nMyP!!Z5$8TZbKx*uHF^;d3Uza4BIW8vHt;K47T#CxFkgtS|`NdzsW% z;sJ%fHaUZ4z9}*Bbj!v+FQHO$X0j;$%{pc zH^qL`X%;R?GJsj!XKKjEs3VLj0`|kCW|QJjR}>UHIQs1m>-bg9eY34L1|Q?t>?G=> z>jM!eI$03213DoJC^c7i83i%K9%P{?K5X*hthFWkL`C!h!A%7tUIEq=@_WkRj_Gp# z8a-8Ri_>VaZ4p&d!(=p-{axA2++o3xJ(d9EaMLmIF364fW~N6r%MW)Ejzt#kYKfpE zEnB-!o@y;oZz#T0_JuMn9wJ#{mE|IsMLnLlXBJg6J;j8`gR^5IZ)sO9^up6WZ8Qu) zmh6!63Bj9QrjK(jwd58}(|u)Qan)OJhF}}@&akqOCE0-`mQ?pGi#F>*d>8J>jyXgc zX}hz!d&nP)w|mMo14agpcbyE`z!nIPYrDV<*4!LVFjU19o|>KFAzDczm(tlK`cHiH z#x+chsztX`Qt8=|_n?$H!*zUbq_cBVE<`mnzWG|KUABli}*?+5Nn90BWU%%1`})Mn;f2u)jCq{INs_{i^uq zRxaE@yyl)FsPXGE{GOZl21--?!;g4_`F=q;JFevWJ*NZ!e#mb(!H}DoId=2U!0V!!Iob zP?)Rv5u|oW$#?h*>{da3e;)3xf;3zbTNb9WvI(p z_s*gA|NlWEq5h>q z3@}dw@eSgDCKdqo$kl{mpa^onTLm{(FMlHZ6b1ri_@ixHNDuQ*mTxPhK zpaYZvmj1tDxVBwfO^g8wLjXLhzOhRAl_mq!8CUaMfZFfBY5NzlUVw7^Xc!k$27q!P zu-vd8E^u61F+YGVO0RkA%f7iN9Suq$!*heaxhmXz8RW8N^f}7M{}$xh3c4y8ea-_^ zG2*>R*Idv_zU-FE63yorzCd~68+)36Y9IWyH2zzcTvSCqX8|U!;r|b4uFi^n)XQas z<8uskf&UERT9^EgjJ&8=e9i&@U<>{SG(Yu=L0icWh>J48pb%6-{~5&Jy5yoPFDQ+e z@P9ya_YX<1%PzSn!3zp8^WQ;S>yqpAcF%d9i~I*JxmJDmvWG6J-kuWy0Kq^N(HrYp zE=a&$X1FXodrlD|_FpkvTS-^dU(ZnhfT;U74|BD1`@wKg!xfZ4>A`=+aIHhG3bBI1 z;EVrzn7@%_1#KEvwG2UxtH}Ig<3HteE}S3yl7_kP>i?u{2ugTW)DV>L%fBT&mpHs^ z?4l$gsIfP|bCrMiwElF*AI8oF3PCMirzUuAQyCa<`L8VgI-B_A{9mv9owgt-)eom% z)D}Ev0sub#TdKcR8U(d{otoacbrbo2>5)HUP=ER3&);c5U;m{_1j=(&Tko6(09gG^ zo@+EOu2VhxAC&e$S+CRBJEsj+_&wiU)e!i5R1g)nYrT3^aqpZH0H6UXYyYcu|7UGp zQrEi<^WsJ9YZkvWyd@bE|3V!EwwyMAB#q&s~zZ-~jE)}_!@~WQS zIU_Jhn%a#~g2rS0y*vL_-4FChx~l63%3Sd;m@i6e{NYeggI5KrKn-dG({KFKA?BjN zYld!6^VezkoCCbmzajG=11+fa>!eH0tqTHE(fsCzzc_w^n!c)Oac&p@NCoO;|E}qa zqavv7>(mR*t=}{IZQEA|I#BahZ-Ad02MT;x-jw-^BOEBf)oZ1o1PQjkO>ku}0=0hi zt{A9wF^8M64l=@k8ow^I{@i@H+ix2O89PAjUX8duw+g&6_xy(J{t|%&wS6@h7u2@0 e*A3bR9SUS6p@6pmfeE02-|W=DbVj~Ee*1rA5$4VS literal 0 HcmV?d00001 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 4a7e3c32..8c778061 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -152,7 +152,8 @@ tcl::namespace::eval textblock { hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} } proc use_hash {args} { - set argd [punk::args::get_by_id ::textblock::use_hash $args] + #set argd [punk::args::get_by_id ::textblock::use_hash $args] + set argd [punk::args::parse $args withid ::textblock::use_hash] variable use_hash if {![dict exists $argd received hash_algorithm]} { return $use_hash @@ -4143,7 +4144,8 @@ tcl::namespace::eval textblock { proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + #set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opts [dict get [punk::args::parse $args withid ::textblock::periodic] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -7913,7 +7915,8 @@ tcl::namespace::eval textblock { #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { #as frame is called a lot within table building - checking args can have a *big* impact on final performance. - set argd [punk::args::get_by_id ::textblock::frame $args] + #set argd [punk::args::get_by_id ::textblock::frame $args] + set argd [punk::args::parse $args withid ::textblock::frame] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8650,7 +8653,7 @@ tcl::namespace::eval textblock { size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id ::textblock::gcross $args] + set argd [punk::args::parse $args withid ::textblock::gcross] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.5.tm new file mode 100644 index 00000000..7ff93c3e --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.5.tm @@ -0,0 +1,6973 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# 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 tomlish 1.1.5 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.5] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #default interp recursionlimit of 1000 is insufficient to pass 1000 deep nested structures as in certain toml tests. + #e.g https://github.com/iarna/toml-spec-tests/tree/latest/values + #1000 seems deep for a 'configuration' format - but toml sometimes used for other serialisation purposes. + #todo - review + set existing_recursionlimit [interp recursionlimit {}] + if {$existing_recursionlimit < 5000} { + interp recursionlimit {} 5000 + } + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + #This reordering idea is complicated by the nature of tablearrays - especially as a table header references last tablearrayname, + # and duplicate table headers are allowed in that context. + #e.g + #[[fruits]] + # name="apple" + # [fruits.metadata] + # id=1 + # + #[unrelated1] + # + #[[fruits]] + # name="pear" + # + #[unrelated2] + # silly="ordering" + # + #[fruits.metadata] + #id=2 + #The TABLEARRAY record can't be completely selfcontained on the default parsing mechanism - because it is legal (though not recommended) to have unrelated tables in between. + #If we were to 'insert' later related records (such as the 2nd [fruits.metadata] above) into the TABLEARRAY structure - then, even though it might produce 'nicer' toml, + # we would lose roundtripability toml->tomlish->toml + # ----------------------------------------------------- + #REVIEW + #todo - some sort of 'normalize'/'grouping' function on tomlish that at least makes records self-contained, and perhaps then (optionally) reorders resulting records sensibly. + #such a function on the tomlish may work - although it would be unwise to duplicate the validation aspects of to_dict + #The most practical way might be to use to_dict followed by from_dict - but that would lose comment info and formatting. + #In the above example - The decision by the toml author to put [unrelated1] between related tablearrays should be respected, + #but the positioning of [unrelated2] between a tablearray and one of its contained tables is suspect. + #Both [fruits.metadata] table records should theoretically be added as children to their corresponding [[fruits]] tablearray record in the tomlish. (just as their name keys are) + # ----------------------------------------------------- + + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE TABLEARRAY WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #removed - ANONTABLE + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + #todo - configurable - allow empty string for 'unlimited' + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + #find the value (or 2 values if space separated datetime - and stitch back into one) + # 3 is the earliest index at which the value could occur (depending on whitespace) + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keys are lists {parenttable subtable etc} corresponding to parenttable.subtable.etc + } + set sublist [lrange $keyval_element 2 end] + + set values [list] + set value_posns [list] + set posn 0 + foreach sub $sublist { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + lappend values $sub + lappend value_posns $posn + } + default {} + } + incr posn + } + switch -- [llength $values] { + 0 { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + 1 { + lassign [lindex $values 0] type value + } + 2 { + #validate than exactly single space was between the two values + lassign $value_posns p1 p2 + if {$p2 != $p1 +2} { + #sanity check + #can probably only get here through manual manipulation of the tomlish list to an unprocessable form + error "tomlish KEY appears to have more than one part - but not separated by whitespace - invalid '$keyval_element'" + } + set between_token [lindex $sublist $p1+1] + if {[lindex $between_token 1] ne " "} { + error "tomlish KEY in 2 parts is not separated by a single space - cannot consider for datetime '$keyval_element'" + } + lassign [lindex $values 0] type_d1 value_d1 + lassign [lindex $values 1] type_d2 value_d2 + if {$type_d1 ne "DATETIME" || $type_d2 ne "DATETIME"} { + error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" + } + set type DATETIME + set value "${value_d1}T${value_d2}" + } + default { + error "tomlish Found multiple value elements in KEY, expected one. (or 2 for space-separated datetime) '$keyval_element'" + } + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [ list [lindex $values 0] ]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole [lindex $values 0] (type val) - not just the $value! + set prev_tablenames_info $tablenames_info + set tablenames_info [dict create] + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + set tablenames_info $prev_tablenames_info + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + package require dictn + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + + #Declaring, Creating, and Defining Tables + #https://github.com/toml-lang/toml/issues/795 + #(update - only Creating and Defining are relevant terminology) + + #review + #tablenames_info keys type created, defined, createdby, definedby, closedby ??? review keys + # [tname] = header_table [[tname]] = header_tablearray + + #consider the following 2 which are legal: + #[table] #'table' created, defined=open type header_table + #x.y = 3 + #[table.x.z] #'table' defined=closed closedby={header_table table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k= 22 + # #'table.x.z' defined=closed closedby={eof eof} + + #equivalent datastructure + + #[table] #'table' created, defined=open definedby={header_table table} + #[table.x] #'table' defined=closed closedby={header_table table.x}, 'table.x' created defined=open definedby={header_table table.x} + #y = 3 + #[table.x.z] #'table.x' defined=closed closedby={header_table table.x.z}, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k=22 + + #illegal + #[table] #'table' created and defined=open + #x.y = 3 #'table.x' created first keyval pair defined=open definedby={keyval x.y = 3} + #[table.x.y.z] #'table' defined=closed, 'table.x' closed because parent 'table' closed?, 'table.x.y' cannot be created + #k = 22 + # + ## - we would fail on encountering table.x.y because only table and table.x are effectively tables - but that table.x is closed should be detected (?) + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + + + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keyed on tablepath each of which is a list such as {config subgroup etc} (corresponding to config.subgroup.etc) + } + + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [tomlish::to_dict::get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #tleaf -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set tleaf [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set tleaf [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $tleaf]} { + error "Duplicate key '$table_hierarchy $tleaf'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + dictn incr tablenames_info [list $table_hierarchy seencount] + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + set t [list {*}$table_hierarchy $tleaf] + dictn incr tablenames_info [list $t seencount] + dictn set tablenames_info [list $t closed] 1 + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } + + } + TABLEARRAY { + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + + set NEST_DICT [dict create] ;#first blush attempt at referencing supertable tablearrays + set tablearrayname [lindex $item 1] + log::debug "---> to_dict processing item TABLENAME (name: $tablearrayname): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablearrayname true] ;#true to normalize + #we expect repeated tablearray entries - each adding a sub-object to the value, which is an array/list. + #tablearrayname is likely to appear multiple times - so unlike a TABLE we don't check for 'defined' for the full name as an indicator of a problem + set supertable [list] + ############## + # [[a.b.c.d]] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of tablearray name $tablearrayname already has data but doesn't appear to be a table - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_supertable_keycollision + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } else { + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #REVIEW!! + # what happens with from_toml {[[a.b.c]]} {[[a]]} ??? + dictn set tablenames_info [list $supertable type] header_table ;#how do we know it's not going to be a tablearray? + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } else { + #supertable has already been created - and maybe defined - but even if defined we can add subtables unless it is of type itable + #but if it's a tablearray - we need to point to the most 'recently defined table element of the array' + #(another way of saying last member of that array)?? + set supertype [dictn get $tablenames_info [list $supertable type]] + if {$supertype eq "header_tablearray"} { + puts stdout "todict!!! TABLEARRAY nesting required for supertable [join $supertable .]" + puts stdout "todict!!! todo.." + #how to do multilevel nesting?? + set EXISTING_SUPERARRAY_ELEMENTS [dict get $datastructure {*}$supertable value] + dict set NEST_DICT $supertable $EXISTING_SUPERARRAY_ELEMENTS + puts stdout "todict!!! supertable '[join $supertable .]' elements $EXISTING_SUPERARRAY_ELEMENTS" + } + } + } + # + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + #first encounter of this tablearrayname + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[[a]]} + set msg "Cannot create tablearray name $tablearrayname. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_direct_keycollision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no collision - we can create the tablearray and the array in the datastructure + dictn set tablenames_info [list $norm_segments type] header_tablearray + dict set datastructure {*}$norm_segments [list type ARRAY value {}] + set ARRAY_ELEMENTS [list] + } else { + #we have a table - but is it a tablearray? + set ttype [dictn get $tablenames_info [list $norm_segments type]] + #use a tabletype_unknown type for previous 'created' only tables? + if {$ttype ne "header_tablearray"} { + set msg "tablearray name $tablearrayname already appears to be already created as a table not a tablearray - invalid?" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #add to array + #error "add_to_array not implemented" + #{type ARRAY value } + set ARRAY_ELEMENTS [dict get $datastructure {*}$norm_segments value] + } + + + set object [dict create] ;#array context equivalent of 'datastructure' + set objectnames_info [dict create] ;#array contex equivalent of tablenames_info + + #add to ARRAY_ELEMENTS and write back in to datastructure. + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #MAINTENANCE: temp copy from TABLE + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + #set supertable $norm_segments + set supertable [list] ;#disconnect from main structure - each array element is a new context for key paths! + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey '$dottedkeyname' kv: $keyval_dict" + #dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #wrong + #TODO!!!!!!!!!!!!! + #lappend ARRAY_ELEMENTS [list $dottedkeyname $keyval_dict] + dict set object $dottedkeyname $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + TABLE { + #we should be able to process tablearray subtables either as part of the tablearray record, or independently. + #(or even a mixture of both, although that is somewhat an edge case) + #[[fruit]] + #x=1 + # [fruit.metadata] + # [fruit.otherdata] + + #when processing a dict destined for the above - the tomlish generator (e.g from_dict) + #should create as 1 or 3 records (but could create 2 records if there was an unrelated table in between the subtables) + #choices: all in tablearray record, tablearray + 1 or 2 table records. + # + #We are going the other way here - so we just need to realize the list of tables 'belonging' to this tablearray might not be complete. + # + #the subtable names must be prefixed with the tablearray - we should validate that for any contained TABLE records + + } + default { + error "Sub element of type '$type' not understood in tablearray context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #todo? + ##end of TABLE record - equivalent of EOF or next header - close off the dottedtables + #foreach dtablepath $dottedtables_defined { + # dictn set tablename_info [list $dtablepath defined] closed + #} + + if {[dict size $NEST_DICT]} { + puts "reintegrate?? $NEST_DICT" + #todo - more - what if multiple in hierarchy? + dict for {superpath existing_elements} $NEST_DICT { + #objects stored directly as dicts in ARRAY value + set lastd [lindex $existing_elements end] + #insufficient.. + #dict set lastd [lindex $norm_segments end] [list type ITABLE value $object] + dict set lastd [lindex $norm_segments end] $object + #set lastd [dict merge $lastd $object] + lset existing_elements end $lastd + dict set datastructure {*}$superpath [list type ARRAY value $existing_elements] + } + } else { + #lappend ARRAY_ELEMENTS [list type ITABLE value $object] + lappend ARRAY_ELEMENTS $object + dict set datastructure {*}$norm_segments [list type ARRAY value $ARRAY_ELEMENTS] + } + } + TABLE { + set tablename [lindex $item 1] + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + #As our TABLE record contains all it's child DOTTEDKEY records - this should be equivalent to setting them as defined at EOF or next header. + + log::debug "---> to_dict processing item TABLE (name: $tablename): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablename true] ;#true to normalize + + set T_DEFINED [dictn getdef $tablenames_info [list $norm_segments defined] NULL] + if {$T_DEFINED ne "NULL"} { + #our tablename e.g [a.b.c.d] declares a space to 'define' subkeys - but there has already been a definition space for this path + set msg "Table name $tablename has already been directly defined in the toml data. Invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + + + set name_segments [::tomlish::to_dict::tablename_split $tablename 0] ;#unnormalized e.g ['a'."b".c.d] -> 'a' "b" c d + #results of tablename_split 0 are 'raw' - ie some segments may be enclosed in single or double quotes. + + + set supertable [list] + ############## + # [a.b.c.d] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of table name $tablename already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] header_table + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } else { + #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable + + } + } + #table [a.b.c.d] hasn't been defined - but may have been 'created' already by a longer tablename + # - or may have existing data from a keyval + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[a]} + set msg "Cannot create table name $tablename. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablename_keyval_collision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no data or previously created table + dictn set tablenames_info [list $norm_segments type] header_table + + #We are 'defining' this table's keys and values here (even if empty) + dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here + } + dictn set tablenames_info [list $norm_segments defined] open + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> normalized table key hierarchy : $norm_segments" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + set supertable $norm_segments + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey $dottedkeyname kv: $keyval_dict" + dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #end of TABLE record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dictn set tablename_info [list $dtablepath defined] closed + } + + + #review??? + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + #take a raw string and classify: result is a 2 element list comprised of KEY|SQKEY|DQKEY and the value being the appropriate inner string + proc _from_dict_classify_key {rawval} { + if {![::tomlish::utils::is_barekey $rawval]} { + #requires quoting + # + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + # + #we'll use a basic mechanisms for now to determine the type of quoting + # - whether it has any single quotes or not. + # (can't go in an SQKEY) + # - whether it has any chars that require quoting when in a Bstring + # (if so - then its visual representation might be unsuitable for a key in a toml text file, so escape and put in DQKEY instead of literal SQKEY) + #todo - more? + #REVIEW - the backslash might often be in things like a regex or windows path - which is often better expressed in a literal SQKEY + # from literal examples: + # 'c:\Users\nodejs\templates' + # '<\i\c*\s*>' + #If these are in *keys* our basic test will express these as: + # "c:\\Users\\nodejs\\templates" + # "<\\i\\c*\\s*>" + # This still works - but a smarter test might determine when SQKEY is the better form? + #when coming from external systems - can we even know if the value was already escaped? REVIEW + #Probably when coming from json - we know it's already escaped - and so we build our dict converting keys to unescaped + #TODO - clarify in documentation that keys resulting from to_dict are in 'normalized' (unescaped) form + # + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + set k_escaped [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + if {[string length $k_escaped] != [string length $rawval]} { + #escaping made a difference + set has_escape_requirement 1 + } else { + set has_escape_requirement 0 + } + if {[string first ' $rawval] >=0 || $has_escape_requirement} { + #basic string + # (any ANSI SGR sequence will end up here in escaped form ) + return [list DQKEY $k_escaped] + } else { + #literal string + return [list SQKEY $rawval] + } + } else { + return [list KEY $rawval] + } + } + + #the quoting implies the necessary escaping for DQKEYs + proc _from_dict_join_and_quote_raw_keys {rawkeylist} { + set result "" + foreach rk $rawkeylist { + lassign [_from_dict_classify_key $rk] type val + switch -- $type { + SQKEY { + append result "'$val'." + } + DQKEY { + append result "\"$val\"." + } + KEY { + append result "$val." + } + } + } + return [string range $result 0 end-1] + } + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + set K_PART [_from_dict_classify_key $k] ;#get [list SQKEY ] + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + set result [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + #(SQKEY & DQKEY do not have the enclosing quotes in their returned val) + #if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + # set VK_PART [list SQKEY $vk] + #} else { + # set VK_PART [list KEY $vk] + #} + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + #REVIEW - we could detect if value is an array of objects, + #and depending on parent context - emit a series of TABLEARRAY records instead of a DOTTEDKEY record containing an ARRAY of objects + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + + #we can't just join normalized keys - need keys with appropriate quotes and escapes + #set tname [join [list {*}$keys $vk] .] ;#WRONG + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list $K_PART] = ITABLE {NEWLINE lf} + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + lappend result TABLE $tname {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list $VK_PART] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + #review - where to make decision on + # DOTTEDKEY containing array of objs + #vs + # list of TABLEARRAY records + #At least for the top + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + error todo + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like tentative_accum_squote need to do their own append + switch -exact -- $tokenType { + tentative_accum_squote { + #should only apply within a multiliteral + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-squote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-squote-space { + } + default { + error "--- unexpected popped due to tentative_accum_squote but came from state '$prevstate' should have been trailing-squote-space" + } + } + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type single_squote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + MULTILITERAL { + #empty + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + ''''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "''"] + } + MULTILITERAL { + lappend v($parentlevel) [list LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + } + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + tentative_accum_dquote { + #should only apply within a multistring + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the trailing-dquote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-dquote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-dquote-space { + } + default { + error "--- unexpected popped due to tentative_accum_dquote but came from state '$prevstate' should have been trailing-dquote-space" + } + } + switch -- $tok { + {"} { + tomlish::parse::set_token_waiting type single_dquote value $tok complete 1 startindex [expr {$i -1}] + } + {""} { + #review - we should perhaps return double_dquote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_dquote value "" complete 1 startindex [expr {$i - 2}] + } + {"""} { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 3}] + } + {""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left dquote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {"}] + } + MULTISTRING { + #empty + lappend v($parentlevel) [list STRINGPART {"}] + } + default { + error "--- don't know how to integrate extra trailing dquote with data $v($parentlevel)" + } + } + } + {"""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 dquotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {""}] + } + MULTISTRING { + lappend v($parentlevel) [list STRINGPART {""}] + } + default { + error "--- don't know how to integrate extra trailing 2 dquotes with data $v($parentlevel)" + } + } + } + } + } + triple_dquote { + #presumably popping multistring-space + ::tomlish::log::debug "---- triple_dquote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTISTRING { + lappend merged $part + } + STRINGPART { + if {$lasttype eq "STRINGPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + CONT - WS { + lappend merged $part + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_dquote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g tentative_accum_squote does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + tentative_trigger_squote - tentative_trigger_dquote { + #### this startok will always be tentative_accum_squote/tentative_accum_dquote starting with one accumulated squote/dquote + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + single_squote { + #JMN - REVIEW + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERALPART + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + triple_dquote { + set v($nest) [list MULTISTRING] ;#container for NEWLINE,STRINGPART,CONT + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + tablename { + #note: we do not use the output of tomlish::to_dict::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names from + # a structural perspective. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$trimtable'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablearrayname: '$trimtable'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + #puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + #puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + single_dquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + dquoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + multistring-space { + lappend v($nest) [list STRINGPART {"}] + #may need to be joined on pop if there are neighbouring STRINGPARTS + } + default { + error "---- single_dquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_dquote { + #leading extra quotes - test: toml_multistring_startquote2 + switch -exact -- $prevstate { + itable-keyval-value-expected - keyval-value-expected { + puts stderr "tomlish::decode::toml double_dquote TEST" + #empty string + lappend v($nest) [list STRINGPART ""] + } + multistring-space { + #multistring-space to multistring-space + lappend v($nest) [list STRINGPART {""}] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + + } + single_squote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from tentative_accum_squote pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- single_squote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + enddquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + untyped_value { + #would be better termed unclassified_value + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + unset -nocomplain tag + if {$tok in {true false}} { + set tag BOOL + } else { + if {[::tomlish::utils::is_int $tok]} { + set tag INT + } else { + if {[string is integer -strict $tok]} { + #didn't qualify as a toml int - but still an int + #probably means is_int is limiting size and not accepting bigints (configurable?) + #or it didn't qualify due to more than 1 leading zero + #or other integer format issue such as repeated underscores + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. (looks close to being an int. Formatting or range issue?) [tomlish::parse::report_line] (no space level change)" + } else { + if {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok] || [::tomlish::utils::is_timepart $tok]} { + #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a localdate + #e.g x= 2025-01-01 02:34Z + #The to_dict validation will catch an invalid standaline timepart, or combine with leading date if applicable. + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + } + } + } + #assert either tag is set, or we errored out. + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [dict create] + dict set Bstring_control_map \b {\b} + dict set Bstring_control_map \n {\n} + dict set Bstring_control_map \r {\r} + dict set Bstring_control_map \" {\"} + dict set Bstring_control_map \x1b {\e} ;#In spec it's included in the list of 'must be escaped', as well as the 'convenience' escapes - so we make it go both ways. + dict set Bstring_control_map \\ "\\\\" + + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + #8 = \b - already in list. + #built the remainder whilst checking for entries already hardcoded above -in case more are added to the hardcoded list + for {set cdec 0} {$cdec <= 7} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + # \u007F = 127 + dict set Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + #plus \e for \x1b? + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + append buffer {"} + } + b - t - n - f - r { + append buffer [subst -nocommand -novariable "\\$c"] + } + e { + append buffer \x1b + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\$c" + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] ;#0b101 etc covered by a-f + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + #(but still allowing 0 -0 +0) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. (excludes also +++1 etc) + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + + #------------------------------------------- + #unclear if a 'digit' includes the type specifiers x b o + #we assume the 0x 0b 0o are NOT counted as digits - as underscores here would seem + #to be likely to cause interop issues with other systems + #(e.g tcl allows 0b1_1 but not 0b_11) + #Most of this structure would be unnecessary if we could rely on string::is::integer understanding underscores (9+?) + #we still need to support earlier Tcl for now though. + + #first rule out any case with more than one underscore in a row + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_0xFF + if {[string index $utest 0] eq "_"} { + return 0 + } + if {[string range $utest 0 1] in {0x 0b 0o}} { + set testnum [string range $utest 2 end] + } else { + set testnum $utest + #exclude also things like 0_x 0___b that snuck past our prefix test + if {![string is digit -strict [string map {_ ""} $testnum]]} { + return 0 + } + #assert - only digits and underscores in testnum + #still may have underscores at each end + } + #assert testnum is now the 'digits' portion of a , 0x 0b 0o number + #(+ and - already stripped) + #It may still have chars unsuitable for its type - which will be caught by the string::is::integer test below + if {[string length $testnum] != [string length [string trim $testnum _]]} { + #had non-inner underscores in 'digit' part + return 0 + } + #assert str only has solo inner underscores (if any) between 'digits' + #------------------------------------------- + + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + + + + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements by default (for now) + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + #some question around implementations allowed to use lower values such as 2^31 on some systems? + if {$::tomlish::max_int ne "" && $numeric_value > $::tomlish::max_int} { + return 0 + } + if {$::tomlish::min_int ne "" && $numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + #note - Tcl's string is double will return true also for the subset of float values which are integers + #This function is to determine whether it matches the Toml float concept - so requires a . or e or E + proc is_float {str} { + #vip greenlight known literals, don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + #doorcheck the basics for floatiness vs members of that rival gang - ints + if {![regexp {[.eE]} $str]} { + #could be an integer - which isn't specifically a float for Toml purposes. + return 0 + } + + + #patdown for any contraband chars + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + + #all characters in legal range + + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + + #Early Toml spec also disallowed leading zeros in the exponent part(?) + #... this seems less interoperable anyway (some libraries generate leading zeroes in exponents) + #we allow leading zeros in exponents here. + + #Check for leading zeros in main part + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #----------------------------------------- + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_" || [string index $str end] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_ + if {[string index $utest 0] eq "_"} { + return 0 + } + #----------------------------------------- + + #decimal point, if used must be surrounded by at least one digit on each side + #e.g 3.e+20 also illegal + set dposn [string first . $str] + if {$dposn > -1 } { + set d3 [string range $str $dposn-1 $dposn+1] + if {![string is integer -strict [string index $d3 0]] || ![string is integer -strict [string index $d3 2]]} { + return 0 + } + } + #we've already eliminated leading/trailing underscores + #now ensure each inner underscore is surrounded by digits + if {[regexp {_[^0-9]|[^0-9]_} $str]} { + return 0 + } + + #strip underscores for tcl double check so we can support < tcl 9 versions which didn't allow underscores + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + #All good - seems to be a toml-approved float and not an int. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_datepart {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_localdate {str} { + is_datepart $str + } + proc is_timepart {str} { + set numchars [tcl::string::length $str] + #timepart can have negative or positive offsets so - and + must be accepted + if {[regexp -all {[zZt0-9\-\+\.:]} $str] == $numchars} { + #todo + #basic check that we have leading 2dig hr and 2dig min separated by colon + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}[^0-9]{1}.*$} $str]} { + #nn:nn or nn:nnX.* where X is non digit + return 0 + } + return 1 + } else { + return 0 + } + } + proc is_localtime {str} { + #time of day without any relation to a specific day or any offset or timezone + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\.:]} $str] == $numchars} { + #todo + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}:[0-9]{2}([.][0-9]*){0,1}$} $str]} { + #hh:mm or hh:mm:ss or hh:mm::ss.nnn + return 0 + } + return 1 + } else { + return 0 + } + } + + #review + proc is_datetime {str} { + #Essentially RFC3339 formatted date-time - but: + #1) allowing seconds to be omitted (:00 assumed) + #2) T may be replaced with a single space character TODO - parser support for space in datetime! + # (RFC 3339 allows space instead of T also - but doesn't specify it *must* be a single space) + + #toml-lint @2025-04 doesn't accept t for T or z for Z - but RFC3339 does + #toml spec doesn't clarify - we will accept + + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 not ok - 2024T not accepted by tomlint why? + # 02:00 ok + # 02:00:00.5 ok + # 1:00 - not ok - RFC3339 requires 2-digit hr,min,sec + + #toml-lint.com accepts 2025-01 + + if {[string length $str] < 5} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\ \-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + if {[regexp -all {\ } $str] > 1} { + #only a single space is allowed. + return 0 + } + #If we get a space - it is only valid as a convience to represent the T separator + #we can normalize by converting to T here before more tests + set str [string map {" " T t T} $str] + #a further sanity check on T + if {[regexp -all {T} $str] > 1} { + return 0 + } + + #!todo - use full RFC 3339 parser? + #!todo - what if the value is 'time only'? + + if {[string first T $str] > -1} { + lassign [split $str T] datepart timepart + if {![is_datepart $datepart]} { + return 0 + } + if {![is_timepart $timepart]} { + return 0 + } + } else { + #either a datepart or a localtime + #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day + # without any relation to a specific day or any offset or timezone." + if {!([is_datepart $str] || [is_localtime $str])} { + return 0 + } + } + + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # array-value-expected,keyval-value-expected,itable-keyval-value-expected, keyval-syntax, + # dquoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # xxx_value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + #--------------------------------------------------------- + #WARNING + #The stateMatrix implementation here is currently messy. + #The code is a mixture of declarative via the stateMatrix and imperative via switch statements during PUSH/POP/SAMESPACE transitions. + #This means the state behaviour has to be reasoned about by looking at both in conjuction. + #--------------------------------------------------------- + + #xxx-space vs xxx-syntax inadequately documented - TODO + + #review - out of date? + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> keyval-value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXsingle_dquote "quoted-key"\ + XXXsingle_squote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + enddquote "err-state"\ + endsquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-untyped-sequence" note "possible datetime datepart"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"} + + #untyped_value sequences without intervening comma are allowed for datepart timepart + #we will produce tomlish with missing SEPS and to_dict must validate whether 2 adjacent barekeys are valid + dict set stateMatrix\ + keyval-untyped-sequence {\ + whitespace "keyval-untyped-sequence"\ + untyped_value {TOSTATE "keyval-tail"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + #2025 - no leading-squote-space - only trailing-squote-space. + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + + #itable-space/ curly-syntax : itables + # x={y=1,} + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #we don't get single_squote etc here - instead we get the resulting squotedkey token + + + # ??? review - something like this + # + # x={y =1,} + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace {TOSTATE "itable-keyval-syntax"}\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal {TOSTATE "itable-keyval-value-expected"}\ + newline "err-state"\ + eof "err-state"\ + } + + # x={y=1} + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + single_dquote {TOSTATE "string-state" returnstate itable-val-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + single_squote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + #double_squote not currently generated by _start_squote_sequence - '' processed as single_squote to literal-state just like 'xxx' + # review + # double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"} + + + + # x={y=1,z="x"} + #POPSPACE is transition from itable-keyval-space to parent itable-space + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + newline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + comment "itable-val-tail"\ + eof "err-state"\ + } + # XXXnewline "POPSPACE" + # We shouldn't popspace on newline - as if there was no comma we need to stay in itable-val-tail + # This means the newline and subsequent whitespace, comments etc become part of the preceeding dottedkey record + #e.g + # x = { + # j=1 + # #comment within dottedkey j record + # , # comment unattached + # #comment unattached + # k=2 , #comment unattached + # l=3 #comment within l record + # , m=4 + # #comment associated with m record + # + # #still associated with m record + # } + ## - This doesn't quite correspond to what a user might expect - but seems like a consistent mechanism. + #The awkwardness is because there is no way to put in a comment that doesn't consume a trailing comma + #so we cant do: j= 1 #comment for j1 , + # and have the trailing comma recognised. + # + # To associate: j= 1, #comment for j1 + # we would need some extra processing . (not popping until next key ? extra state itable-sep-tail?) REVIEW - worth doing? + # + # The same issue occurs with multiline arrays. The most natural assumption is that a comment on same line after a comma + # is 'associated' with the previous entry. + # + # These comment issues are independent of the data dictionary being generated for conversion to json etc - as the comments don't carry through anyway, + # but are a potential oddity for manipulating the intermediate tomlish structure whilst attempting to preserve 'associated' comments + # (e.g reordering records within an itable) + #The user's intention for 'associated' isn't always clear and the specs don't really guide on this. + + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + eof "err-state"\ + newline "err-state"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - multiline itables appear to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + #dict set stateMatrix\ + # array-space {\ + # whitespace "array-space"\ + # newline "array-space"\ + # untyped_value "SAMESPACE"\ + # startarray {PUSHSPACE "array-space"}\ + # endarray "POPSPACE"\ + # startinlinetable {PUSHSPACE itable-space}\ + # single_dquote "string-state"\ + # single_squote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + # comma "array-space"\ + # comment "array-space"\ + # eof "err-state-array-space-got-eof"\ + # } + + ## array-space ## + set aspace [dict create] + dict set aspace whitespace "array-space" + dict set aspace newline "array-space" + #dict set aspace untyped_value "SAMESPACE" + dict set aspace untyped_value "array-syntax" + dict set aspace startarray {PUSHSPACE "array-space"} + dict set aspace endarray "POPSPACE" + dict set aspace single_dquote {TOSTATE "string-state" returnstate array-syntax} + dict set aspace triple_dquote {PUSHSPACE "multistring-space" returnstate array-syntax} + dict set aspace single_squote {TOSTATE "literal-state" returnstate array-syntax} + dict set aspace triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax} + dict set aspace startinlinetable {PUSHSPACE itable-space} + #dict set aspace comma "array-space" + dict set aspace comment "array-space" + dict set aspace eof "err-state-array-space-got-eof" + dict set stateMatrix array-space $aspace + + #when we pop from an inner array we get to array-syntax + #e.g {x=[[]] ??? + set tarntail [dict create] + dict set tarntail whitespace "tablearrayname-tail" + dict set tarntail newline "err-state" + dict set tarntail comment "err-state" + dict set tarntail eof "err-state" + dict set tarntail endtablename "tablearray-tail" + dict set stateMatrix tablearrayname-tail $tarntail + + #review - somewhat counterintuitive...? + # [(starttablearrayname) (endtablearrayname] + # [(starttablename) (endtablename)] + + # [[xxx]] ??? + set tartail [dict create] + dict set tartail whitespace "tablearray-tail" + dict set tartail newline "table-space" + dict set tartail comment "tablearray-tail" + dict set tartail eof "end-state" + dict set stateMatrix tablearray-tail $tartail + + + + + + + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #use dict set to add values so we can easily add/remove/comment lines + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions [dict create] + dict set spacePushTransitions keyval-space keyval-syntax + dict set spacePushTransitions itable-keyval-space itable-keyval-syntax + dict set spacePushTransitions array-space array-space + dict set spacePushTransitions table-space tablename-state + #dict set spacePushTransitions #itable-space itable-space + + #Pop to, next + variable spacePopTransitions [dict create] + dict set spacePopTransitions array-space array-syntax + + + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from keyval-value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions [dict create] + #JMN test + #dict set spaceSameTransitions array-space array-syntax + + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + set popfromspace_info [spacestack peek] + set popfromspace_state [dict get $popfromspace_info state] + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + ::tomlish::log::debug "--->> zeropoppushspace goNextState RECURSE. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + #for multiliteral, multistring - data and/or end + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo token beginning with underscore - never returned to state machine - review + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\{" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename - tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow: + # table -> starttablearrayname + # tablearray -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + array-syntax - array-space { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-tail { + #[[xxx] + set_tokenType "endtablename" + #sequence: starttablename -> starttablearrayname -> endtablearrayname -> endtablename + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + string - dquotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + #for within multiliteral + #short tentative_accum_squote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_squote is multisquote + 2 = 5 + #return tok with value ''''' + return 1 + } + } + tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multiliteral + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + #if there are more than 3 leading squotes we also enter multiliteral space and the subsequent ones are handled + #by the tentative_accum_squote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 squotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to a tentative_accum_squote token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #barekeys now support all sorts of unicode letter/number chars for other cultures + #but not punctuation - not even for those of Irish heritage who don't object + #to the anglicised form of some names. + # o'shenanigan seems to not be a legal barekey + #The Irish will have to use an earlier form Ó - which apparently many may prefer anyway. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading squote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_squote token or triple_squote token + #It currently doesn't trigger double_squote token + #(handle '' same as 'x' ie produce a single_squote and go into processing literal) + #review - producing double_squote for empty literal may be slightly more efficient. + #This token is not used to handle squote sequences *within* a multiliteral + set_tokenType "_start_squote_sequence" + set tok "'" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_squote" ;#trigger tentative_accum_squote + set tok "'" + return 1 + } + table-space - itable-space { + #tests: squotedkey.test squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXtable-space - XXXitable-space { + #future - could there be multiline keys? MLLKEY, MLBKEY ? + #this would (almost) allow arbitrary tcl dicts to be stored in toml (aside from escaping issues) + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + #@2025 ABNF for toml mentions key, simple-key, unquoted-key, quoted-key and dotted-key + #where key is simple-key or dotted-key - no MLL or MLB components + #the spec states solution for arbitrary binary data is application specific involving encodings + #such as hex, base64 + set_tokenType "_start_squote_sequence" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType "tablename" + append tok "'" + } + tablearrayname-state { + set_tokenType "tablearrayname" + append tok "'" + } + literal-state { + #shouldn't get here? review + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType "literal" + incr -1 + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + #error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + dottedkey-space { + set_tokenType "squotedkey" + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + tentative_accum_dquote { + #within multistring + #short tentative_accum_dquote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_dquote is multidquote + 2 = 5 + #return tok with value """"" + return 1 + } + } + _start_dquote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multistring + #switch? + append tok $c + set_tokenType triple_dquote + return 1 + } + default { + #if there are more than 3 leading dquotes we also enter multistring space and the subsequent ones are handled + #by the tentative_accum_dquote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 dquotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_dquote_sequence'" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + incr i -1 ;#throw the {"} back to loop - will be added to a tentative_accum_dquote token for later processing + return 1 + } + } + whitespace { + #assert: had_slash will only ever be true in multistring-space + if {$had_slash} { + incr i -2 + return 1 + } else { + #end whitespace token - throw dq back for reprocessing + incr i -1 + return 1 + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type enddquote value {"} complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading dquote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_dquote token or triple_dquote token + #It currently doesn't trigger double_dquote token + #(handle "" same as "x" ie produce a single_dquote and go into processing string) + #review - producing double_dquote for empty string may be slightly more efficient. + #This token is not used to handle dquote sequences once *within* a multistring + set_tokenType "_start_dquote_sequence" + set tok {"} + } + multistring-space { + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + } else { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_dquote" ;#trigger tentative_accum_dquote + set tok {"} + return 1 + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + default { + error "tomlish Unexpected dquote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0 + append tok $c + } + string - comment - dquotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok = + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + #multiliteral or multistring + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + #review + if {$had_slash} { + incr i -2 + } else { + incr i -1 + } + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $c + } + string - dquotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART xxx WS " " + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + append tok $c + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #assert - tok will be one or two squotes only + #A toml literal probably isn't allowed to contain this + #but we will parse and let the validator sort it out. + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart { + append tok $c + } + string - stringpart { + append tok $c + } + default { + #state machine will generally not have entry to accept bom - let it crash + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + multistring-space { + set_tokenType "stringpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + set tok \\$c + } else { + set tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "literal" + set tok "" + return 1 + + ##review + #set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + #set_tokenType "literal" + #set tok "" + #return 1 + } + } + } + _start_dquote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open string + error "tomlish eof reached without closing double quote for string. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "string" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + + proc _show_tablenames {tablenames_info} { + append msg \n "tablenames_info:" \n + dict for {tkey tinfo} $tablenames_info { + append msg " " "table: $tkey" \n + dict for {field finfo} $tinfo { + append msg " " "$field $finfo" \n + } + } + return $msg + } +} +tcl::namespace::eval tomlish::to_dict { + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "preval" ;#5 modes: preval, quoted,litquoted, unquoted, postval + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + #todo - track\count backslashes properly + + set c [tcl::string::index $tablename $i] + if {$c eq "\""} { + if {($lastChar eq "\\")} { + #not strictly correct - we could have had an even number prior-backslash sequence + #the toml spec would have us error out immediately on bsl in bad location - but we're + #trying to parse to unvalidated tomlish + set ctest escq + } else { + set ctest dq + } + } else { + set ctest [string map [list " " sp \t tab] $c] + } + + switch -- $ctest { + . { + switch -exact -- $mode { + preval { + error "tablename_split. dot not allowed - expecting a value" + } + unquoted { + #dot marks end of segment. + if {![tomlish::utils::is_barekey $seg]} { + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + set seg "" + set mode "preval" + } + quoted { + append seg $c + } + litquoted { + append seg $c + } + postval { + #got dot in an expected location + set mode "preval" + } + } + } + dq { + #unescaped dquote + switch -- $mode { + preval { + set mode "quoted" + set seg "\"" + } + unquoted { + #invalid in barekey - but we are after structure only + append seg $c + } + quoted { + append seg $c + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" ;#make sure we only accept a dot or end-of-data now. + } + litquoted { + append seg $c + } + postval { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } + } + ' { + switch -- $mode { + preval { + append seg $c + set mode "litquoted" + } + unquoted { + #single quote inside e.g o'neill - ultimately invalid - but we pass through here. + append seg $c + } + quoted { + append seg $c + } + litquoted { + append seg $c + #no normalization to do aside from stripping squotes + if {$normalize} { + lappend segments [tcl::string::range $seg 1 end-1] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" + } + postval { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + } + } + sp - tab { + switch -- $mode { + preval - postval { + #ignore + } + unquoted { + #terminates a barekey + lappend segments $seg + set seg "" + set mode "postval" + } + default { + #append to quoted or litquoted + append seg $c + } + } + } + default { + switch -- $mode { + preval { + set mode unquoted + append seg $c + } + postval { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + default { + append seg $c + } + } + } + } + + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + switch -exact -- $mode { + preval { + error "tablename_split. Expected a value after last dot separator. tablename: '$tablename'" + } + unquoted { + if {![tomlish::utils::is_barekey $seg]} { + #e.g toml-test invalid/table/with-pound required to fail for invalid barekey + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + } + quoted { + error "tablename_split. Expected a trailing double quote. tablename: '$tablename'" + } + litquoted { + error "tablename_split. Expected a trailing single quote. tablename: '$tablename'" + } + postval { + #ok - segment already lappended + } + } + } + } + + #note - we must allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + + return $segments + } + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + proc get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish::to_dict::get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "tomlish::to_dict::get_dottedkey_info DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + +} + + +tcl::namespace::eval tomlish::app { + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + tcl::namespace::eval argdoc { + proc test_suites {} { + if {[package provide test::tomlish] eq ""} { + return [list] + } + return [test::tomlish::SUITES] + } + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::decoder + @cmd -name tomlish::app::decoder -help\ + "Read toml on stdin until EOF + on error - returns non-zero exit code and writes error to + the errorchannel. + on success - returns zero exit code and writes JSON encoding + of the data to the outputchannel. + This decoder is intended to be compatble with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help\ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc decoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::decoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::decoder] + } + + #fconfigure stdin -encoding utf-8 + fconfigure $ch_input -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts $ch_error "decoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $j + exit 0 + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::encoder + @cmd -name tomlish::app::encoder -help\ + "Read JSON on input until EOF + return non-zero exitcode if JSON data cannot be converted to + a valid TOML representation. + return zero exitcode and TOML data on output if JSON data can + be converted. + This encoder is intended to be compatible with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help \ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc encoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::encoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::encoder] + } + #review + fconfigure $ch_input -translation binary + if {[catch { + set json [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts $ch_error "encoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $toml + exit 0 + } + + punk::args::define { + @dynamic + @id -id ::tomlish::app::test + @cmd -name tomlish::app::test + @leaders + @opts -any 1 + -help -type none -help\ + "Display this usage message + or further info if more args." + -suite -default tests -choices {${[::tomlish::app::argdoc::test_suites]}} + @values -min 0 -max -1 + } + proc test {args} { + package require test::tomlish + set argd [punk::args::parse $args withid ::tomlish::app::test] + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + set solos [dict get $argd solos] + set opt_suite [dict get $opts -suite] + if {[dict exists $received -help] && ![dict exists $received -suite]} { + return [punk::args::usage -scheme info ::tomlish::app::test] + } + + test::tomlish::SUITE $opt_suite + #if {[catch {test::tomlish::SUITE $opt_suite} errM]} { + # puts stderr "Unknown test suite '$opt_suite'. Available suites: [test::tomlish::SUITES]" + # exit 1 + #} + set run_opts [dict remove $opts -suite] + set run_opts [dict remove $run_opts {*}$solos] + set result [test::tomlish::RUN {*}$run_opts {*}$solos {*}$values] + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {[info exists ::argc] && $::argc > 0} { + #puts stderr "argc: $::argc args: $::argv" + set arglist $::argv + # -------------- + #make sure any dependant packages that are sourced don't get any commandline args + set ::argv {} + set ::argc 0 + # -------------- + package require punk::args + punk::args::define { + @dynamic + @id -id tomlish::cmdline + @cmd -name tomlish -help\ + "toml encoder/decoder written in Tcl" + @opts -any 1 + -help -type none -help\ + "Display this usage message or more specific + help if further arguments provided." + -app -choices {${[tomlish::appnames]}} + } + try { + set argd [punk::args::parse $arglist withid tomlish::cmdline] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + puts stderr $msg + exit 1 + } + + + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received -help] && ![dict exists $received -app]} { + #only emit cmdline help if -app not supplied as well - otherwise app function can act on -help for more specific help + #puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + puts stdout [punk::args::usage -scheme info tomlish::cmdline] + exit 0 + } + if {![dict exists $received -app]} { + puts stderr [punk::args::usage -scheme error tomlish::cmdline] + exit 1 + } + + set app [dict get $opts -app] + set appnames [tomlish::appnames] + set app_opts [dict remove $opts -app {*}$solos] + try { + set result [tomlish::app::$app {*}$app_opts {*}$solos {*}$values] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + #The validation error should fully describe the issue + #no need for errortrace - keep the output cleaner + puts stderr $msg + exit 1 + } trap {} {msg erroropts} { + #unexpected error - uncaught throw will produce error trace + #todo - a support msg? Otherwise we may as well just leave off this trap. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + if {"-help" in $solos} { + puts stderr $result + exit 1 + } else { + if {$result ne ""} { + puts stdout $result + exit 0 + } + } + + #set opts [dict create] + #set opts [dict merge $opts $::argv] + + #set opts_understood [list -app ] + #if {"-app" in [dict keys $opts]} { + # #Don't vet the remaining opts - as they are interpreted by each app + #} else { + # foreach key [dict keys $opts] { + # if {$key ni $opts_understood} { + # puts stderr "Option '$key' not understood" + # exit 1 + # } + # } + #} + #if {[dict exists $opts -app]} { + # set app [dict get $opts -app] + # set appnames [tomlish::appnames] + # if {$app ni $appnames} { + # puts stderr "app '[dict get $opts -app]' not found. Available apps: $appnames" + # exit 1 + # } + # tomlish::app::$app {*}$opts + #} +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.5 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.1.tm new file mode 100644 index 00000000..2d8de97d --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.1.tm @@ -0,0 +1,5341 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.0] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + return -code error -errorcode {TCL WRONGARGS PUNK} $result + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + set opts [dict merge $opts $defaultopts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg opts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + ##try trap? + ##return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + ##throw ? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg + #arg_error $msg $argspecs -badarg $argname + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $::errorCode] $::errorInfo + } + standard { + puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" + } + enhanced { + puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" + } + } + return + } trap {PUNKARGS} {msg opts} { + #trap punk::args argument validation/parsing errors and decide here + #whether to display basic error - or full usage if configured. + puts stderr "PUNKARGS OTHER: $msg\n$opts" + #JJJ + return + } trap {} {msg opts} { + #review + #puts stderr "$msg\n$opts" + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $opts -errorcode] [dict get $opts -errorinfo] + return + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lapend solosreceived $fullopt + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" + } + arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } else { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for [Get_caller] requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg + arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm new file mode 100644 index 00000000..95d5c702 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm @@ -0,0 +1,5473 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.4 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.4] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -default error -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + 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 [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "Option '$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 + #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "Option $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 + #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + set msg "Option $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 + #arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index a099c9b0..4c0ab79d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -661,7 +661,11 @@ namespace eval punk::mix::cli { puts stdout "$current_source_dir/$modpath" puts stdout "to:" puts stdout "$podtree_copy" + #REVIEW + #todo - copy manually - renaming any files/folders with 999999.0a1.0 in the name to the applicable version + #(allow either shared files/folders or custom files/folders per package/version when in extracted form side by side) file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm if {[file exists $tmfile]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm index d70d657c..92b214d8 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm @@ -759,7 +759,7 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [llength $buf]-1} { + if {[string last \x1b $buf] == [string length $buf]-1} { #only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b @@ -769,7 +769,7 @@ namespace eval shellfilter::chan { #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer if {[punk::ansi::ta::detect_st_open $buf]} { #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code #todo - configurable ST max - use 1k for now if {$st_partial_len < 1001} { append o_buffered $chunk @@ -778,7 +778,7 @@ namespace eval shellfilter::chan { set emit_anyway 1 } } else { - set possible_code_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of possible code + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm new file mode 100644 index 0000000000000000000000000000000000000000..536e3fa3bf724e2b979b4a297a88d29d74284f07 GIT binary patch literal 51527 zcmce;1zc2H+dhmS-67Hp-5t{1AkvNG&^a@-fTT2%BB26;q@*HUN{N7klyr%xq!J>0 zd%%EmJm-C$_w)VF@3$Cc_TFn<>$-E@d+oshoq5su+Pi^l?47_MFMF6BNXNol~yepV1 z$l2Ay1qSl6gLevi& zXbW}$LoDE(dO+=6Y()Tw@UBHfoa`+{M4T-g!Davkv(s-u9IiGtP%sSU;|2y@CWIGiO3kQmJQvbO>G8CzMvtn5I3CuF*~LYys}?0vx?V|y1HR}j<+V($hs z^@ooPKLPm9?_3XXg1`_6Kqc*W7$>a2JS@q zEMRt=AZ9mLDAXQ)4%EU146p;7@AyDqcMvTt z=*A5Yjq%BZz~1&y7!>s5_@Bp53pxkpJTyQY@VQ#sLqMl+fd5?JqW_8K+{NEdH?wfD zHUre=`!x_(SJ=r#r(M7-?45pHZ+fl+Ckuc{TNjWq)Xm8rc5>Fw&NxiJ(|*#ycda~k z^@%q8l{Ek{*AJD3qyEv~Z<&O;dO)mBXZKInah>f1(ED=;{6SzRDEK!jM)x<}finUH zYz)vESCAJNWM$z3%nxqC7H)13S2u_~U^q@b=emb0D{#!}RL7uTD;UU68YJ^Oora%! z!iSR+*u@s`F!a)Ay`Eei;6OpCS#Sm-*KdWI*&lH@`jQ_f!2bu;1?w+qgo&7JzT@29SaL;3qTF zd$ar_ac54K`Hc>oPUJhkC*JA1albF?Hu8!{eB|9|Mt5c z{Fbx7Ujd)Kla&P&Y9>4|0ivXQ?W{htg5?gr1Gc7j;A*aBhi zEc#Q|ZFH>s+(D_bI;sy|(;XRvzL`2{-gkK9f zi9)V6K-@k_Z9qWg0?gbRp3waG3UZoq{dR6A$^v)MX26i&V+z+P;U{SPSpClfF@;AS z;C!$(2OtV~Qgt?X{B4YXj2>{x|4IP7r|)z8TSq_6KNvjV8dX^Q;gsuNspfWpAw-@~=w_niPq zDiDu(xq10GxP?VP=R5g+FoENSi8C~!QgrYVmgzHFae1<*aZXwvO>74{DlY# zB#=;7Af@_&9Rw(s6W9U@1KGkeU}tzr1iV{=oh*EyARrOTP(Cl{J`0J--obUof1ZyDk1v!ENz{Y=9kbicjv|L=LsszunP7RF~ zB5)z9@2W z1w`j&eZmRH_sr~6ppGuCUcj>CobJL^)YSt9fOtfcFF3 zKcIG}PT$7f8&JR#BydCi_ksSNUi^UY&qq#WdRD{#F2>(38vnZZ`yVBIj)K!10Q5t; zC*pv6`~T(O-vtjy?v$#N{(#VDeCDI+zms>)*?72|BKi%Uf3=YB<&$4^5*r{uov6u= zwKlvw1mswNiJTN+P6F0x`U0Xqlhpk)*58ZL|My;i4)8^%RG&+?Ku`}$U?l=9nq2|Y zw{Y@;hf{bcgeMySI-tV#v+M*c$$|0%d`W(qlX!w%?19q&hx)5d24p{Q?LEB|kRm)3 z|CXokMTP&Rl>gS{zh;SaHWp4!mOy$7Hz>IC2Mq2<4)wR5;D$n{F2f1Z2hxj^ti=k* z>w)MAr{W|Fa0Xk$%Mc)dHz{B)N8 zYC!Poe|X-%_e_y~m126!arB${8606g??rE22%efX1KpB5_&+(o0 zlcFPBD^IBhbn~QUYz?yX0rEr_4?y$+|y{uL0_iIe+jc<_ae6Hs&F{AW{xqx}m~ z9iX3+YB5k!1_8MdkVL>G4~+KRJb;B3JY@iSxA;*Mh9}v-YRPZ_KUw^4YbPaSH(;WG z`F*b~1L@cgsQ(V|)aB3vRQ^_};dA&`Gl8D~f1NC&h%GlkxWAs=^_yV0sCbdh%gZl7=dqp z#2=WeGf=X!tPYf;=5|2o8 z5~<;rCqsof$oaIEz^|NEBlA>+zu~*wfniFUtLE#ea?_ec2?xvPX6;P4j4xN&?rfI@ zDDQoJNj>{w`?6$MT7y64m3J&CLU*F3XGmqmkXKN~K5mY!6(ze|xV$QVz-OEI;wp>S z>&G{_dStw&-wQ zm#Cwjr5?L9+AD?gJ;8c-fTXKfzY^Q1jpNddxw#l5?+)AR2LzZf;SVmsA`M?*jr|Bp zbwwIJV+`mwh%N=UYiwVYLAJf#|BS4Vs{yH_eDGo<{WzcCru}U~lniu&_#Dya#nO05M@%SU8dPHmn1YORG&hn2&o$Vzz zSHA=W!nU1xRMP3TFo_L`DAOC2$*(1t4Vfk0!ZKh9QGQguMqe1y)ON*yE`9ts^=i@n zhn;%?{R;+~jzY9?kL+iPFFcm>;V<^Y_fmeFG*04NXv#>tpBVdvYoASjFlvzcjRqS? zC4I;@R*=a-Q_2vXO}1*#Qn+Vw7FzGzmMuHeSOcx1;m0x)dVjh9(}MV15KWII-K5S? z-cyU7mJ&Vb*I}2oZcjdVjFG9#5aRu2K$x@a%ePdwgBe#O&UNFb!dN>=eJ?-Ff*Vqa z+Hocf8gop)M(B~JSW#79yU|ILZuv+Ld8qixvrPz7O5GP4o5!4#ZQPvMH&+(yxR=qOE>&_<(FTHMh-RtTnPdq z{15OFLO}UX{E8X8#02#KiXc!fOQ4d=3IBY24D@mV3E@}o4a^ZnO2+vyMi>YPcESh< z*AP(u+uq@s08sh&umbKTfw|6o`aUQUFeu_jV`nItFu_s7(IwL{{pp8@hFw#aADej9 zhE73EEnS5lLX1Omp2r}(Xt(pEFE@-j4wy<@ro>vHpMKcqRNDS7kKqZGxUUge9PP4c z70a!(<0d>F)Q`yNZ2mB!N@4x9mqA>H2veL4lcAsSXPMYQ%Ly?8mnu@~ryk`$Pka#^ zi&X7K?tTs0j2)}M)0wngim^2 zH#3pvar2Q4`M~y4V^Atf+@*`pwhW&8n`h$&4TyC}PxWp@lgpwtbJ2gn*D4;nvzmF! z7m0f4lR!maG@80ebB5JwS^2Jg0PjT!=XT!#bL!8E;x1U)x3UCMokiJu59e;V=Pq65 z6%FHA;cyVf4NY%t@n7|1s>qCghpt{;Ymu$ck`u9@l*M+m9={@suV{fmzq+sG{4Ke9Nit- z33l{4D0O=LUaI+>xS6-_tzDI;sQK>%%(Ax+X%4^bq2OOhif*~ZG68-dC-j0L2TZiV zfLp-Kjf`F(Re-e+id!BbGBLwEF1cyygCsss9D%#8OE_sZT=qUtp(-GIt|#W%-JaP* z%Edx{B6nPfOO)5ln*5W%9Jw7=& z8c;xeXo#Vsj_(I-wAG$`BpOQnh|~kCT(L0iqu!5Z#-nN{10Rf%=CXOefB6WHFX*sU zX4akE>MgQ2T9CCwVl$dMarA|Bk z@XE!fH4Y+gmvgl4_#S_IvWubbUghQC;q#;n*8X5DN#a(L%cxjG+btwYBSAq6S`a?{ z6svpPfR|$)x_03l|IC0r>-sFeg`&yKy4mL$v(GIWqq^%J>$Zy-qmN?!Da+X%W1`(? zhiI}EWV>?}y|j+=d%k339bS*0T-)}!+rDPZUgdeO(5niDuWaax!}m46L^D1GpY;Z< z%-})lEq}RqMLw&+F#LDSomXR#YEvXSX`-NA^n)+JGX=qxwv;M?&yNkCRbIPhhu$eR z&#t?RVW2jkP}H)408YJXq6EtBEx??6viNk$P0*b)Wmwd{g7$9j{&s zt=^3Zr4EUB#oFTBFJC6<+j3+kl8)Ni3u*GDaPLm+rQNZ8kMO1#p}7%x-}rO#C71Fh zaYs?o(XDqr9&g66ig{nI5A$T+WfkOS*PN@!GMm6CF>{f_Yl-0yHhA+u)?k60HF&yS zpvLW9^@H)vjUWni~Si4tR|Ggw6a_#o%rnhL~?QS5abSx{0@%8m5<11bv?Vuj^W%r@Z z0Wi|h74;)%_B)0Cs6tWC*IXE(^WKhb%M$t3W17(sovFe#vz?2HIP7gJ{fcqof#ghk zJZiiC7G3ti>(pwV#d5cYTeLn6FB&5ZIXlXi*FJTt6Y#THt9$W8ktM$1AgX}(y{xKP zPE?wzm!Y52^~H*GwYi8o!6%!%CV93;J4VPa@=_BB0%YWwX1H;&DjGZgCZaq;~cBLIpUUEAAQ_y3RDOUE$*V ziZi)&kWH+cH#eo_)|<++Wh>A43w!vP0a5hg{0@db+ZPxb;b_$*pYz zbsjvYj!+wCT%cTd6S4*?P|tWzL2|?Vj)Q`tL9WeBI?)k9PXuqt03L65>E399S8P;j z=}Ln)$S@lbLv)b|7X_dm7Asv{h;0u;z%O~W%L0RltVpZPzpXlzE0B7BnZJu4V!MW2 zC`}?FaqQ;dv#H9vXahlZj(4kU+qurt=B-ap#uup38?KrN)-5FjEZ%UT2%e2tN}Rl~ zU_Q(`{2_I^^PBC;qrRDR$#0({`4IR@=|=pIOghFTSd^;n!0mJTmkPEHoZQn+el-n=|_5Nru{eYzC(fHxsXK8&4e$@h?wh ziF{z@6~^L@S9e)bU(j|gdUtUU)b+XRak^Rs=cR`o5T+ip&+O9?XjuFA=VowLZ}p4b zq`pCG#~1Cf+o=82CnkX2_l5L8y)E<3v1X&<&PRcq8DVpl+qN0Q#eUA|tM13dg!j2H zhMFiLk(3s?R9v-W<1?S}o@sG5NbhuQ41d_7FScYaO`=A)8%+P8vi?*0GvPkYZdB}K ziCCK6%P=o>Q5mUFby19G3+(JS7uA~g($J}@#xiO{LJw6V7{2P_*L!j}s~|`>s$f6Z zLBt{xBOS6ozU~;Z$T^wMz}=Xud!S=1IN?>*nkt`GZOWb^g;LYXGkWFOrAJpbtG!aM zcfthk-L0ja?I-P{rUMU7Z5?rXI%`|Elu&Ez>#&=D8@&2%leoF0G_Xc!+9aK{dFDBR zXht~BvWt_N)sr+ffy8kIEd~m5-SBh}-YA6^xK2T#+PE>i-m5qM6Q#bsnHh5m>qtXJ z^_Crpp2y9?ZdZ36wy%Cv+P;!y$yc5rtwtQ~x^_b*Id}B`xc$M&tYEaQ5#!+lH zsXO=h!mn(W=0eE1T-g`Mm;Zw`_}N_98tnOFfo|sP0c^7bHlP8U7oAR0SvpQmw(qO= zAMbxZiPOfy!`sQ;#qn&O-NhDZG|lRC#|EeljA0=lDE{|(HUubfSOYt3+_--JcQ(Jy z(^qv}5X6(vZ?tYQmN@4`JEDBOI8hwg00Fo-TZuy%Oh|IHE-I_VB{@hm z(yG;U*R{zf(eTDxNAMI6CdW{Is&RP{zQ#x}c>%*)hmr2V_jUd|j%umQ{S0>ZAch5r zu(VBw^bB=_M_pzH7BASkgDtRcB^rLwu5M|RfvFeEyFb29c@uBLS>M>jNYBkyZp$?% z)o#-v_XCdHk{)I(^&#oU(M$ZFF}Z>s-o}s?c^M*4dxKIwV(Ijlr$9tu35+?H}A`#zIjqYwD(bL_aOT2`*6}vm%0;o zF#>rcpNxYI$8d_Exs>2p>?vuGT@qe}pA%`m9dpV;4yiRd^YCk5wqX>lLT-st^RyZw zcbZzKZ9&qjd8s3a5^rzoQ0;?+kkpRb`?B}2xyFuDz+s65Lnz&_uW8J0^t;W>r`Uw& z2|4e{$0xL#1~}!HysF51*T6wdwDQ*8E>rnH<)dTt;0WGLdq&+`9x3^&ihFW~Qb)lr zIkwakWQE`MPTmkWs0vnD<+-B)nOUrntJ&|lx4e;A(p4hT}MV~N)djo zvW_$DMcSvVs<_s#BDuR!#9eogK;8ZO$ydaK_U|J>ZRcsX*&ZH+e_MMU+s+QfDXb89 zRVq_39~qTLW9u8B@3KoaSdPzita9gS9eXo-V0Y^MswL`8{+h>e^YQBejGHgEuU3uH zaCfE!bn&kBxILgerXC96e1W}I!nN>ZRq$E)vH!G{cZAX|nMjUn1j^UPMVkffP-~e_ zw$8jVbfEQJoWpO0hcmWIQyaMhn`O80>Y+zCm(%B-ua^lfU`*Giac@R)Dj1LiTo|sI zG(h(c2BHW@hd!}%IceCF7z?e;tFesLLah6=@c$rSn?!{+erfYf^9V@zC9^s@> zv@5)>4<-_^XP(xUwdlHBM3`q{h=(ECaw#R6?h;tiM#kIaHW8nS4f@E@+q>=d+Nez- zaya%hLP~79dOTzskhibZNG5$$b#p!g|8o1?QH6`_4U_YzkKcb zbymaDc3S~Sz{f&>cKyHiwLksXFOOyhzfl3@vVcG=e9T;J%hEP^ z(JR-D&@0d@Ko|@c!AOznQBustP$Fd;e!l@>0U^jG2+JiP%Ox;)$}8Z>Gvdh;V?4pA zXfSCoIaBmNiefdq@rvRO?F9sc8KCL?5odfBI@FBk1oH9mN$tZlLHt@fH(vPeVU&K~ zZHB0Km&>_zEDJ*oq}X-CRUyu$BA#G!`ER?Kl+0+|Tb+&T;wx3%Uy<*Xcjk0dc3?P5 zPjf+)e5iD=J-}9PlRXvtokl(wg8MTgo^}N2TA5l6MVUl3-6OS*vDTyUb&k&_h|pRj z-F%M5Ur8bVxX8P)oSn3BKVC1n$jkn{F6(WR-5S3uUUr(6y9X8i-uTs_>{v@P z3c+GFhvb~Amrz`Bj6y92G)1GCJ99l&ebdxMAkQ@V1?8roeH{!kh zLd$@#PGcR$$UBGw7kJ;++BN@0IGI=CT^IqutOLyq0r|g;;s1kP{SXd^E5zQ`-o?V{ z_!t-mkdfnwjHHg*qj|k~^7kF;U}!M(WKIs#;9FJxSLLi(lvo*$o0x>{Rixjo`LEZC zMmF4EAoc52WmjR>yvDTnjdq5mKZ`Y+(+M4J#BLxsHqNfS-h2g=&Tkf;xShow!vQn93- zuJaB1~ojbw(pOZ+BGe~^7%O-e*6Tr_eW^_Tr$1dJ&8t7uFHVE3Cq zGx+c8lK(6x_^oRw@DzX@+>X4z*DdAaDsbAkvE+7dgpKrVpvK&|;CT6pN2I(`@Wy_$v~Z-^GMgEhwEi)hL%cKiCfg?X{nB{m$(m5@&#xX|A(}kQDAso_a{Fp-%yM1 z&f${mBfjBuStE$PeQ^?bb61E}t7d!k(|%j%wk)ATXoQb)=6Vapr5E1Q1S$tIDT(MM z6zBvjIsT(w-lQGw2shnENZB~t5U#mJgH>Jd-2@X^t?x-8Ulg!^h->V0XH8DACL2i& z$IG+)UD6S9hu!uLD+8k`qoSGJV#6WP4j{P zKMFwmqyE#C@!=*`a;4d|BZYN&8rsA%ndnE4zFuO9Jvch@WA z%Gj8o-b1I`1qnP#&v>7ZbX_>(li<33ZT%xy2mq@Ev_I;T&H+9nQotwu!o4)V^aFX& zMoT6fIa(Rw^H%`!?Uy^4DxQQW2Lz}co&cX)Icagu=GdG zZo~;7?Cw_Vn;GRXadzX&`Z4m7h*>lxYG}(FK~@|GO#uR2A&* zSMa%^4Ai5G-e?u3$RFDxtf1Gx?Okq7Fp-}5+_+m6ZXf){P(=MbY8M{;rI8$Tjy4Es zL>`7tC~C>Kc(oo~lENX*%_5JwFhS}D<1^Dk1|&xM#boptm=-tSV+{VJ`T)WK!#Dk% z&y`{mDqKQR+JbgIl1=7J#g2-&`kw(>e(+zxfQtGzOmdVjHEc+C_3bCo(wZ0j{ zT#XCZL>{`f?{BA!+$vK4y7h2aKL?3DQ2I$L`@`g@$Zy}|u6IJQ^Y4qb-^AQ7zxa@; z{A~{MCy{H2@AwTSS|XAjp?e44^Ost%yBcjd7L@uyhj zeDK1@wVg;NvBti1yiPji5xSPswmpR`2fMlKT1)T0ZjNsA;R7Ov`bF<$pY4HXA84Ik zf6Hwoet}hOd>PbXN@db^H?M#0qrznS!OhO+3-8Pc*F7*h$%jg{1oBwp?)suPr(yUg zH=QYFz`1`YH9>O`a0Fri_ZELrwf@5WPhI-SKK=CELo8E7-iPQk1hS8c{O)+xk1-nX zN`%G-)s*q5r0CgSdO76Z{OK_3QYGhupq$6=)jm{J`d%Kf*S{CKr$%_mZa+FI#fFCQ zIobGB{Gx~0=;Cq+<2!eh_t;2YWbDe-QqF4vNFvC3W#%of*YNE^<8DZ`o5#utE=t+k zC*!bKb3e|jhzA5PEAtT1)x9#v$2_=uZH)Wrs-|bhD$}u*+danO7u!=DB~G}nW`dP7P-nrXXAncW{+?0;;rX#fz%U}0%=nzIXfMx0AJ6uO0TvdiNESM7_t}Qv3RVx zggs&rXqavGi~MR64nxaPR7X)X1cX3fkB#1+TnKz8pZ7cafNY-_IJ-^?5ga`>C2c>UV&+G|x)-AYf*;oRaCWLx+hwsX z^@&K?W**6DOO{NQu?kFkUeCBgOgJ|dEHwO4u&rCvp81O9+LgDdS_Z-oX2{n-X1kOE zdRneh-8WrGa`s!do(sNY;zT2<3Tm3gFh0al3Atxfxs?7vZ`lF4tA`gacU*+u*nm3cDWxJ;p%WL7>Rmv_sx3gYpwogNPV<@=3!x8 z-()9CNMo<}R~{&4VXCLxt*=v? z&-HY5^K+rXL1?Wu=k-$f`mojuf;Nw{A4LBSyZy+yyU*a-H}mI%I&UD#rXw; z4~j$FWEMgWijr68ExdK6y5<7~Bf0XR>W3AIB1U|SiuJjV z5=qmPt}XFly(Z*v9~kl_)0e!YRs3K$U!Gq5PAg!s8|JFmPbEPHJGrxa;vmyu|h_K6+#FmF$^7*()zx z0@yVTH{G`)F+~Om@^f$ZwiyLl)67-d;|R%(p-v_A$0&RdIiQbWx&>yAtjGRP-t|7Q z^U|XmI<($q^!SbekBb&&i_nofB~gsl1=Ib)@{J%=5AHwFRiC0%C?GJoG}e()cgH!2 zX@H8qOW(nisfpAuT2ZECukd2rXAr?ufw`<5iI8to#;dvrp!}j9zh@D3Yi{oYb27h2 zkSSzXac$K*5mr*dwFBSEr|I^YdIeiSIEEp9R@!v{hkJ8Ra4Y}KQWvPBr z!HQz)@OMPM2en$fef2e@@Co9KF>XinYrElnw@Rf)RWGc0KbeqnF-F69Of&bo-am=- z9v8YTPvq4T?m27NcT_pt=JkQg?nS%_K}qG?q{kY{1uri7m$>f;?A>)eTB~(zf3o6s zZ>E~GN**n%3GEe>ls`w$Kc28nff?3<{p3#PU6kp}Mdpp0xC@I2Ht8{s7Lstf=a@-j zaVxWWau*{HU3gdJI=6N}SA4`XDHc=FI%Mm8(=*l8m$_3{A%&h?CNKjvGKuNgQM4lC!I`xjrZB_ljyojLaGZ;dzOG}B7Y z=X23*Un;O$iC^Kqm-Q+_1eA8 zh07fgjq%a}XiXB0GzTP@@|Mvm^MpJzlkA)q(W6}SuRI&xK}$gOCGIlKTV(So)~0z@xvT4|PM@;D zxooc(^oYXdt6P<)LRvW{E9!ETzo;CJv_Dl{+|=9JpcV+u0xb3tinmuDl0Vwrc#`Yvj6WK~+~QP5 z5yTj~D<`(+(y~EZH#bVhZ$j5jc4Rr=|DmGcaMQ@{vx+CiRb0V^UTUF)uwK&Q*#$T1i$ySn9y?KF$SS`hn?4BP%1vt z^jM00a=VS(luJ`?Ol>=EQnzPSCpfy8dKcxEv+(?3#8gD-ot;>v+fMT9dzdMc{ULTW zA#=q|?7EL(R>#kMg$zdhDwTvY_FgJ*$;So;%3PlC3!I6`JwCI-Jy|btIBiD*xq3U$ z{%Fo(1MKpL{U~0Z)GR4uRB_rtKt(LGO)C|jSnz%*^2>Wjd6zWVR>eMRYwGy510uL^>{;TlOL0$wm(jr%O{O^4xMaz+mD{*@BC$AfzVy z)Yit&k3uKWkWg^sjUUmE6Xu5H-B~{**6!`)M4cEAzHjw#&hM%9iZH1Xiajj@cUR!A zybaC)Muo#jA~649pqc&23fMUgey&7ZNn-vL^aRoRuio^s*8Evi{WgL{uz_sHdMk&}R_jhBc-3e-_A3yK9QWp97WX zRGMcot~^EtI9aV@36efKvzT+nW;dKCTnP|8Q3`k!>A&8^`Ol>fI}3>QnL4TVEKn`d zx`~*#74w|Hj{(^jIj`$bD=hg?>@z`FVoYy?Q`r3BTb;1M`C-~HNV%Pgga+b6l5BEx zgfp58&!Z5!AEh5ql&NsoaPJ}(p>*N{VqKr6Oyd|a^d=@gF_MlFzs=w|NnUDw!?1A_S zPN`*&+$+%}%GA3T%rFw4g%xGJqpF!SM8hmQg0=lFg|1$5wM-$0e$cfC<8j50=^j~oiS=E-UD%7r-Q?TC?N`UN$tGNh`dO+uIs4KE~=(mH;t*{4UxGs{4QKN zH(VIuponIVb=5Xt^rHcF8i8ndmp4=G^;S(R2qB@emHYDb8FwW~YwA`$flCBxBGp)Q zK8v&{e3Hiz{w>yzh-HsC^jdJ#t0U18uSr){xy7dWApc17u6DJcAdV%Sdh2bEfwC;Y z_v}G2oK%`o^F1vN-Y)hX*Kb%gmEpX^stZW=@G}X^`Y0mGp8e=I_o){ms^K_IGx}9f!!_IUOZ=S|+){BG78GEao=qyK z=q*Wi&o^)LG!X{;$h~?6-7QpiTdeAa37#Q)x9YD<=QH$Hy^ZllPW-gGeeebI^@G(< z%L<2**O!vMvxMD#X(u;J{B+3VN9He*J4)a;}hbl>yEAbfe#H9O=gtT-ZQX zPKZZ!;GSooPr~bvRU3@bFV?X+v(;Nf?1cdztTpJZ%vCZnaimFEZ7Jff1Lp9MRm4Gi zdly7`ACd{VhhnR0h}eWoFggJxy@;It@!6^fM8%V9_s->b1U61C#0Uu=4Ib>N+k1B{ zg(G~qMG(YznsU?zUYaQcyTn%TZ9xX7oe)>ct<0NjHk{c^O&=axU0Th|)LcxElcq(L z=`h2*exaj>#YQ#um3CmoPJImtHG$HwP<>NA;w#BwvQ}R1PgCpC!c%M^YyJGnxai*u zbbI`yF>_-ESV!t?mJ2N7W}6GqTU8G31{Qmk#Fa!-$|g4@nQ*VL=hvz#4H}r#J-VVY z=ryi*#IAuJs(dRo@?nJ9Lnq=@>h2nntzpZf=I1Co+0lXtvQgd2p2XSse6qKd_!5+g zo%%~3mEZ|rzlqYG^s`w^h~&A#%6?HjM3j75FImJo$Dr)_#YitpcZ?BF-G1Y0@>r1< zLlYf7AD*XUXP|x?w$Ih$DyhM5#@pXVCtt|UBhA=K36pH*Nb^$gs&u&a)xF%*mg&uA z!E(pA`^NgFe19eRC6l}g_NFIR`rCcOR>*hAwfYQe@~CYz<3|bX{10C^S!Q*TyoejQ z^={~eL<&|xzuv3;u`EwQV{H*X9hBNNC)ZaLrqZtk*$EigR2L7V+j5`F@;g{&r6MPD zHR4@Q+IHcVGI%q*aU3|2^BPtzari1`u^Z%cSDkt&E@-Ye!Fo+^|Q- z8!wg{lN#x*^k=*`S1vr>-!-`@?(NAc^}bBjB?I@xTKkUJ+dL*N9+P(~hn0eY&Nkr` zd|w!<>#~8Z&e!BZ^11Z&D-&k-M0gR;hD~@bAxK7g{Q(d*)d1zz`IAuyc(nCbHg$5J z-XpFao|n7{az@BHja9ZAo=CUM%oE4`zwX3rN&;MG0Q zUuGHRY4?8hEfk!c=e*cqVNZ@|fqHFL^dbmt0U;(KM=Ix{%-u<>!{LUhgBupPlm~cz znL_EVuvC*J`qqR`g&oN+KzHK{!IhTcS0kovt0huMAaO6Ks1aA2P3gBMFRc<#*7L2Z zZ^wme!f13hZkPa1VBB|}egbT0tqs{Ob!cqz^$!>z|3y+c=CM)|$|x`V#uva5g2taD z$;swd?Qj9{OyeRZ$#aq zM%f>fnV-1+bpK|fK-eJ1D$RhbL(f=xhb2chTX)8*=5?h$PNLx0fg6oJ+x(;yB1=Jm zq3uVVbV`$P>1tgoRr~A(1B7BXm9nSU-e)uM+y`%fDSSsPLEbqpQ^m($nHccSjy=p_ zGr0uytfOI3mgykvka6^IVjT<637;*I>5SpkK#@_L4bfhP$v^vwJ6B_lCPrgx`TVXo zizDsW5m&v!ihZl}X1M1^6f!PuoO?1`I9)zCTVk>Iz+!0?Tx0R>MOdD`XqS~dV)4G#62E>jM zq&vkB38~54U67&8{g(Z3Y+uV8`3G%IwX(H^TU*;AT-%A+sB6KtyZCS9HQDD4^Q#aa zJCyPaD|j5)-B_yjQ%~>j0yQUCi#`*gs!8AQr^GgwnTfIPPAuODGTdk*+3yzFKzh0; znSbfMpPx;d4c1}71q$)_o`e`Q*PFs$WN&%E3Ta+*ZSBc_La2=8^i6d(j41rsAl&r3MmAQvr6N{l63%mtY4Bzcw zQ~m()p1bp|QmNDh_5r|GNPWuMN@~}7d(T-f2EwrtmALyZ zutygGcqR_GV*$AD#_sYhhTve`HSN^#zHQHI_?3Ot=9;!Ot8hii?F3_xj_Q%xh?|6Pn z@jRk)yZGRcqQ^|%qytbof%ZrJ?CDP#{z?zvy2KI3gW1MS6uNs9MMo)OSd<~_uBGw( zg)*8_1TMMLR=JP#w_V1(A$PC0o$_~m!8(_~M!B~{1gTKQYd4&-M`8&}(7l<6gPBT= zOw{y*-G>X;z8F*XImHU$7(Kq_Y2%C${k*8CPw3^eHlEwfB*tLL3%QudFY|Ibvyw`# z@36JEew~WhC%!zMgtd=r7xPdIi38z z;}24P%IK6Ays%xF1CvoBFc#`(#ZpzO_+qh{zipl*p1m z!GZT3_>G(1ip0TmrDP^*b&&Z7R+FDu^e}-rAjw^+Rd9Np_vjYE~d%kLn%S#dT2(8T`{`Iu={)daIr3a70JJ^O%z^gDWqJzyr%bh(IavTl zsRKC5io;iCVX<0gWVmAM`vGKurOpMEZZyq5d#azF+-7%HUyuF5jn>UeX(lyvoU*Zq@ym_Lvp3q9Zxmpm z+!wM%RVjEAr?_fT)fwu8H58s^7sN3j%v9?F{Fn}_?WOEifd>APvi-GZZ#M7~E_|!x zb<0H0O!&ZItp_Ut|+H`rE8}AXZ%K&rwWi=`% zncW?={Bf5E?K^z^>W!9L9qK|lGq$K=P^eYWSK>?jD*m9Xc5z1ngf#JtdxM*RM7Q0Ml=`5^sCugV-h;e{9L-uNcAs0% zJnar=$Ltc8B_+TPInea~Xx#hmzxcmv3y_>&KvV@X8J!4CRv-*VYHBg}=`(lhGjl3k z?bVw<8<63^=m$XIRB$y0n)&~Q8lM6?BQ`)k{srICS%9K!TL!(@FA1XnaD>2hHo*HI z_YwkT@I8O<-$wPc0De#!c0#0c3=e!?uKaH1JX^0kq9DCX>lg!v3ri?TVs&07m7+A( z1+J$@yMAmG{h@KCOFnMmGCP%sF--ib4~wkK@{o2&Zgm?#+{+dnLy%yW3@&AMV*To3 z*GxJl#cwigMQ9ms8@bH~lE`Rr79DMEQ_Wo!8sOFx*gR4nL z*ypWGx=(rJ7Qg})z=qzRw6fD@5`Lyma9?j4CrSX{o9uVrQjzFAztCZSqWhd#5gvx! zGx0?1(CjV03CivaMK$OPg0jzXlf05sV~i3)FtTI`_WH7j35jQ3rfyPhbO(a1npdls zl`Dx<3*?!!K6zi?lrdlnm@L6;Fms$oJup;#L2K2sWBVeYgOKqJO{X2MP+q>U7f0Af z0{ucKzcagM;QIRT4HhQ+P80_~z#m-~oFm|;x|+t-;r9*3ju$Gegc8 zn=TqM|Dkxjrxa$&%B#HzG5<6^;=q@n(*Ql*4bwm7hn$C4U^OkM#6|I ze-cc`&yjiuq?wria5IuMP2$Rdj9uN^Hv?#W0$KAY2UFLS7chucsgoLe2pJzs_?2Cv z2qxuute{e2E3CTwx#LU?0M0{U$jqQDzyo}f<{#Z_{GEp%LI1>`M5_;LUyEYV9Mx8d zW6_LSDk|44(wUD^AlB80($(mD$)&8z+^wX`&8ecvtbVos>MJ(QE_OYoZZ%a^4n+4B zquAuX1kbm%B+K#uavh-k(R*p<(EpU;X{`9`EWS@;37Ciee=-kH`nh@FvPT-NlF9^i z0*^n|0!yoF|3AzT{)Eu42ZrFE&iuAX*7v6%Rhun~y4(m#2LR!SOk%LMIt9s_S4xAOb03B% zv_BDOeB9_<_Z37~r_eBL4yN${J511-jM?O^rL4qm8R}eb#3RnMV;F9W#$6?StXs5V zO4*j@Z;7nZT4TD9w)f-mTqFh4d(F|hfBdS;z-SA@+R!o_SZ6+V!cicd* z8rQ92;NaND^9&ITka@(Su*pnC&$#F~W1wTi0s&nW5Fxfqw!`U3d@j9_&N$>Sbld5i1*Ox$@^_VLk~ zhyiG-^06Lf;>=Y+GUWV&EI~e;?>l6uXj_0niTcoD z%oEJ7@(p>k>>vkkj+Z@lu{5$&SMo?SW-J!nD*aeF)XHeS_=ur>S>tadXgaEP*m+~F zr^!FVuVK}=l6jAYc&&l1O}&>njZ+Qvp@Q1CY#P&-wg%YQZnU`0InA@Q*yW#4GN;?tw3;^es$EiK90Wl3CXx5E-i#TmovY~nCfaI2TGXg80Z zoAVr(+pzh&dhmAmwLGtLSG1;Yky=d(x0t{G6#Gu_G{*5DjjyO+XC#z*PMiI`F?y|t zSlJ!zggZ(oq5{IhyqRxC7b>pChRl%G9xpgi?O$v*)>ifs;_68QqZuy39$X+UMZ4LQ zwqc7vFo(FJF%)vILigZW#Bmsj;0tILZj*e6NW4|FU0NmCGU?0e&|Wc{1k=cBV#0*a z>A1>bGc{wBtxHRh2MqDIXS;aQjckI1cZl9ZT_(ZNatRjOyRFvgxJHgqrm zN8b@9@O9?t#vLX{iIj=YDFg>;6nfvuCo=mJHtQ*9_AzNLG57;X4 z`7+dNGX*xy_FBtcs|gRa8f&(YDIqs4@GbCUQfV0nh(8dN3=ctlL|rEwBMtc=p+>Cp zlq!L|A-&gpT23QbO^T_W++a=$cmHW+(mSaOS87nxCbfGd>B1??LS}>wsVHzSCvQ&h znCLR1U(XDMsP)>DwUOU%nPAC4YL_=SDuH5LY}QaHs~N8!#u_zVWMIh{)*#aCuSb-I zxaLvP&aH4;(+NpV_X*rLz0g5d!rNH%c`$^Rw)Y(#%ZTs0LLOXt^2Y`VdHQx*Lb)$n z%38CtQFA0U<**G{SoojLI@)~}m%^9M{w$HZ@yv!kTJdZABgSiQ_z&l=Rm&eIJcCI# zvyN&hbFJK2+7bPg$dK^)pL?Vo_TT57C%**sn;&L^Kg|w*Kmu4aoc?&z`A;Wa_2%u;dOj$^R`d2ROc8>o;vJE#L{y<@pl9YF$<(4%WVY?LkfM z%KxvovjD3)i}v=RrKD53JC*KIQo1_?q(NyxQc6JSlgL*YA)GjfQz z_s+sDLPD?C4Nt@Gp7Wr3*nz#oy{!qqXb1>OJulX>xXDB2-!icnj0# zfV0&gitYiMAJiQ(@3#O=-B_u|m8W66mJ^e#3{bG%p9o*(AAO8F(8Er(M#+0`<1yDm zG+i4aI<@E|P<5#F#NM}bPIaI^M%+=5o^Ac>VNoeKmKfg-z`x#vO+b-o^_5)CXkqah zJZsPc=hzIEJ9kXB+QK(X$znXE7?yEgIbm zl%{d^s@BX>be^*!|A^}ttA3ltBR3~^pG=Bw_8k8^-rF7}CCx*wI>jm;XCE{yF(cXV zSKgjhSC46wD(w5i_!#r4eN5`f4c5}Y*16Rr7PZtj{OXLtH4AqZa|eaFL4}fyQ_Pmk ztfx*l)9EzYWEa5@BXy@rwq-HL!-ZGch?sDMGERiyGy;tZ$B3| zsF9<4iOuaVqvN?t1)>W+mV?@K6Wa=e!G%!Z5JOhX|eag9@WDAykeNowP<;Kf) z=kJ)sYPdb+duCaX@;q9BL>8hnqN>hc!?p2U%AFk>)7sp?ozggdUHkFx_HOp$P<%AF z>@$|S(5*QmZ(u_*0vq?hC*tXikN=R95LZhz)E-s6g<_>H>9(s|4{s=m4CgW$GeD_JTE8VZBW zqgJ!7j~D<7bV;hWLTds=^Z>D=XZV;di}f0dDlMvlv(+q2Yis(H2t#rrVzFI*GAz6a zrMmDz{uPO2Tp{xOpQtm2U}y&9gxI{9$iu>EY|>EB$~>&Fr>S?zrY$J4?LQiG31v!C z;eL+gmCp;m!_Qzt0j9ycg%AG{JM&EfL?xz9>#S1RzCi86qyQt|0A+JF;f&io`$g74 zcha6lua>E*)gzLu>Ii&VHVNqcp{cvn2u!nZORU7cnCGg;&SGVRg!I+zNXIxFPLhvAnIoyoi(Xw22L{u)icT zw|#&phS7)hbIKq$C~n++6f}YoqicneGgF#^sTj`rl*e8bVjXn=t3PuN{forYAlUez zW?l%FG2>BnS)~KpqtDKFnYF<6tKcLGKHkbHR5RrcvYp${e%%pNJumXIH!%|N4r+b5 z(L5$$S~Lf^m3f{JWRF>M4cj4A+lxDp@znKT(8Xyj&}886#>P~}RAsuU85B-CI*Y?T zEwRg@3z|3K@cF0rMq41Vjx~()FQeu}KD>oj_tFGJLJy7A4uCJLEYv7AA=00%Y zl8LKBmqWJ8?&`N&*vY+yoA|_MvXUl2sTd+{#Zld!7#y=Y(%qN+6u;Cs);V^N(NUVC;iC;8($GIDN9WIKBaWyoW7`fA`Gq=eplX1y2RPzb>~>{}r@mosPHWAR92 zZ2@PTz2;*QTaZ)e#D=+39#BSWQNK*%jn$Y_F5be?loEwGzdO!e^-8zD`*h4>yRC(4 zY59Do`R@;P*Q6=WtVGziE!fhn7pXr;A}c$vBi@s&nWGu>4x+|hh;3pfmq~9S_`0GD zz`@*)3*#?%aY|@0dvJ2c{2?2;PT0Fw#6l&B9o~4^_p6mPZ(X= z7Rz4E9n0Gz9@)Dr^*L!GjIddQmu7Zq25#|wn%t3Iw{8iP;ti~Yq*9Rwh%cO|WVc~s` z&eU=>kMX0%(X2msG6$C4v*GZyTm4E;T?H@880gW2h4+T}jBzirsm;b;PfIpIGKWkl zB5Mdr?z4FB6W&1j7e{GoPZAR27ff|XC{S{}KTsO*FcF(&q~RPe$60?GXy4(Ruc0i9s(<5}M|RAytXI2B9l{7XN$;4}UKg}T=_|vs3bU7YHkcq7!_V-emfRIm z%wyk>R7cumDD7JOXGpyd0X>^{hF|x6IdV2ycRlSFF{%jQj*L-``2l+U_^Q!^e zA7Qfpe2?j8f{VZAKv!4G8!>WL6HLhMGp`PBQwFrK`NQn{jlg82Aif-eWl=&C?jXBg zy!ye^+(a&Xi!Y7?QYdNk{R5W=WT6YCjGuSTu-e6I?bBsxx(Eg6JiLj=B}^bv`IMGD zPz5+s@$`g+B;K-!1vEef9Un9|W+C+}=2Jbao`>cfAkV_EY{bw+v8cwst(PM73*$YEhx53z*3;gE(tClFA+f4QkGB}um?=fk z1SgE^x_j`x3s?}BM1;muhzHI&EWOR=Erc+ch@OC-vp^!1WDG_c7Z~z_1hcg=4$v;h zWZj6)B*x#D_KIG8Lf&fWfCJ}l*_V`k(jUytyfz;Ew(4Pf_LfiI)GGt>JPnO7yZmz0 z7+P>X!Qm&tJE_x|8hKTjMrb|5EynkpV{e63J!yF^H9zxqXW7<&&cD7}ypx-!SGw-h zabC;Udo4Sp?_LpB>?&Q3u&^^3^yf``j%Zh}<)uEGWA>SodZK`yGfBMWd%JB5i3Q>- zM%^5V7>8Y%`$?Va_ageMn9;?bxtA6l1eS#JCn!x6mbs^Vr$RZ~&#oUjb+v2?$k;9=BK zvYpCqkHEME*%M*lH@BP;PBs;*g3z%zVO}EKM6RSLIpxRTW7H4n2u^NAP2`NL38mQh z;yy#7({?O)sJA&hfu(M$v3T{-;Uf`#ERr17EgTjkAz9iTH_{iDYDGe#W}<84>RXh^ z9$=-e=8S?Z4Ec6A^m&@<>iL+1^>C4Jkvo!;*0a0qwZtM7UxLGHV!}!TrAsE(S0{|e z;$KsH!llBcRu*!SZyUndn=HMOdvEsjs|qm^4h_#Y2F1efAXfwtfy*ZJ&RmBB;P&c1 z3;^(BWBs3Q^LIRKDSaUfgA#G|DqiK2y^w{Fw%B!K5tc!0vmX#Be zrX7K`FqfFlMFdD-da~EgOVQ{*YZ2B&j?WeLv7ru8yO)Fy$AylJ0C$?Ao};)F%H#}J zQ1nQDFe^67rQ{yZ1`<3K`4dfOx7$bbRE-s$Ro$+yI@X!`>I=aRgsZ;mEBP4NKQXPS zktm2PeNxe5SwJl`9>qbiV&-VgC>T0c;CLE+$d5~Zv z)MGcmMlg%kv!TRFe{`2?JQC+=QNRiDZOr4oXcG!v=I1Gm?#bPbi3Z;Tw)*K~Q0q2( zM%?(mD-zL~o*tt%KshHd11?ogv{NDQ+zgmbO`b3W2q*e$EEIAjsap3RqEhE0Qrs_QYw-NT|u_1p94dbv#z zBLyA<)8dGoyqM=hXIGA|oAHEZy_L(4gj<8anZ3>ODdEW~7uvXc=~m1Rp@T0tMzH(z z`!kSO2o+#Qzh-UHLI|8hStI_~#Q(?1J}yt9E^Y7qweF4j<3<8d$L8CM#@_7E<_cb% z{m21d%hEDtIwJ?z0A3jp!|~$9X~?;=k8*VFgyR&lxXva|iqmmwSqXX}Z0n<#+Va#HVRu1IZ-Kp>@VYM^PqUz~=`eke-VHCwsc~!Q z1I02ef@OmZ7X^QCimGzTBf~7JR64BHS*_^sE)_I@A|7laFy4|PMBKivZ5q*}8V-kC zq)RY94v-EXDhc-RX*jV@CmQyL!)8&u^;k8+;$mr3vq`W#VMYbBzJkt#-p>9Bd_LF1NRFQtd=d zDUNQ!B^q5t%3H7dW;Q(@J1|f9KLcKFi86?(KaG}p{rrHDc85N#` zW3ai$27SjmpL+NK`@F)EBD9_#`}e?jzaJ4gzuD(q-Ll)H zE(p8H>3Xbo!-J0DgAqwB5~LK}1^H!&O=l-E6?oizL;aivM1r1aCj%>aIt)z(JAy+} zEH?08@gBs!R)T)fpw>c$DA?8jY3$j=D~^LA503+d(rn_m=#omz!&If4!jgWV2#E92 z9Kh(&Cx-3ndq&vC(kja0r+}9zq2i@RwP|Ik+CMsC$0k02O_ND3cC^< z2+-=XGE`$==H<|VuQ?*rGs_4O_#$aUrxb$u2++8idGQ4c$54CcsRBe76)W?z=KV^| z^KEmuu7Pm}()!aXEM$Awom1HHv9p5&W zgQJT9QJa6DaPKvlqPNcjUV>aa{6LzL3=52|dyn$hZ$t0g4W@90d{$OJes{jDbllNB zA;MxtL2B050OwBSql`t|kf0%2@LI1rw!X<~En{Bo0OW@cS+civ`e%npc+ApCVY*n4 zF&&8G`c2<0Zmp!1;ah&r;H^KJHI7I12+`hear2~AIDUvX5f9JDEX*{#~;3&XUvuRrZY+v7%sZ{ z{a%h_MOX6p)1(>nDw(0{VA=aO_hZPTQoGLJ#s|J!)Xa#-$6{VR?-65_O~2r$>|^cb+}jm^!n3H7eRofhf?Lx66{M zCf&^RMj-7Q*r~TxI<88X{2f-S)d`l_Qx3w~65qC1{~`sIATUwCwdm3#L(fLf+EHp# zT+JS-(mFnVI**=o9MtlA9e7#_m_|yWQHr|pZ-RZJ-Vk%$(R}G^41tU$u`)_7;xGD+ zpOZbPu`{aC!H;B5T){Wz1R3$=0#d4A?jy~x5fOIDCevV<^v>R}FZQbQ(jNEqn(SI# zSp_R0s9_!h9s~H;0mR3SZq8gBtXV?6CD0@~2)V1YlEKOEzv9|Q8SI;Ym7)=N!)mi5 zRNxll7Q2UhNc&1btT@W^$Y)P84d2{f*;!db-6uAaw4BEAC|w!j{T2gJWo$(PPkT^C zLLe)wcoY?Ia)qo*l7O}RWllN?ZyrF;SS0?anA*c*|ByvDXRQ)8in$lT$_FQMBzGHG zrz|Ula}cF_)}bzw!%|JmK zCVg}ey`~fW8y#65=b?_Zb(|9`L-3Bzo92?uBYbtl7p>Khi$^AncEoON$m_T_!bDH*>~~awJGbiWbbJ%$Gp3sx6oqmKz(;D&%OEehiz{ zL;xjOz&3O&{!xFrYU82B?Qm7=%+CWpg+lkmm+bID1niJwjtQb^RFfpyV(!n~K`e%G z6^GCzKn|VHR6>d}aa(Ej*%(_Cd8_x%VU1wuNGZeRn7HmC@0g-!F1yxFi}ltBU7VEs6teb8GnkXSM(^> zRxgM!qWyqCLVtVLMIQe%Z*>e%*+7#wqK^x;f}Equ8-{bNUBF2oMDBCRcu<#T-S^WT z+8*wT<%u#)1Z&R4a7S#DL5eSVo7}r)o+tAHuLB0#pVRIB*d^o^c<-$)(k+ z*dSQVF4fO1J3I2?y1H?DFE`J2e>rXj93s%d(>DnPI%?{(ZykkqIPwnBzd%DR$~KTw zP@JECB}?__R&2J~e;HAsF0z*0WEj0dcG`I; zf|RO2K}#0L8uF!%diXm7#-!AnhtqDJTAvqntKeJeCB$9BTkqp|FL%?6Am1rVp?kT% zI6T=;%9=|RzO=#AH^e*-8Subpzb5ytg^~Gp!&NZ9HI`QI%s^>YBDf$_4zRbr!0${+ z%}Rz(&M!#DN(Z1mCl@ppG;YEgsN8WVL|WW@`ilE)3j|RjWQ>_qt0~qeRjDz>CR>;& zu3K9fBGQERqTL=N`pe=@Xg%%egYkj!d*V}H{SmUf=za2VJ2{nDn>c8MrpWcwRs0`Q ziR_Wu#O@MptO<=^itZ=GcR5EORn~&NAmzJPIwUiRrVb+(iI~f8R?C>TyC$sLrT323 ze>m16DZ^rR-7#TLV5HXqjnWds%=V$=z^cc=!^}#R+m-{NCoG-$u+zh~JR4tDaXuE4 zvBPSoLvFDzIh=r7q?3u0WT<;Ol#{lSa!fB*@3fBDb?!*uVVX~knqx6qRxcAottc71 zRnHlth3|AGa!Z8O@v`x>ViqEW_&U; zU@OK~J;ePecLEv!*aL1v{)>E+muEGXPx$}pr{aNnpKQp_`5A$N|BckLx~g0)twoIj z{0L@6P-er)d$I`PL<6W6r4dvSY4g~gz-bM-#ab)l({J*b8M1dP9C_q3T^uQ66@|X_ z8wv;xFjAwThZEA!jIMO9z*3?_z<#A3a6uKyOob0X8()E)We(GoLxoQ_3OG*a3-RgT zMG4v!8u=P3t1~zYuAZ;{itxT%52eH&ads0y=Uqhw(`V>!Y^STnRi^Q>IN)ONfN34X z{Bd0*ipW|d1ByjEf*#zFLJ`S|@Ci~llxqLr&yFpfEk=MqZsrN@4w1`B4v z7KSn*%_~p>X;1LA_jUui5mKT0Qpa2*VcM&rFEmGm){3gc17`=j_>dYD>;nP zBwMt^ZpY-8=R^=3i)6!MOhT{6sFNCt=cJiF+jPp$Q*Ss9HML3737D_39M6Vtp+?%x z-=*kd;`U;X@-BIFjAuf%VlV=gH&SgX?I=ycdyZf$te`wsczDvkwN<^8nDQW|sJC-lOgO_FPaCZSML}4A6>_Ot zvDaW60_Kg^R$Q|&|5juZi#wEoc2^7`%t-1`B_0LIe)dQ!u6SSy1_XV^QS(S?+Pcm1 zN|r-hMW4xd;UF(HtjNH6JvTHSFI4O`-FUj8%h-FQ_$`N_?6)+BN7_dp9uE*k{LZRS5gqWdC7{?~NppvNK-X575 zWk}Rz-?QRgPpmW9eIe6{dRI``;0r~-9F#6&F__;MdlLvuXa5v__+!`zJ$Bi{)*2V} zzWhqzo#Sr=SfWOO_0|+Km7VUkKmOI|`*gxqb*KBla$6^%^NlU4Gm&T@0YVfnt_0g` zUcaljO{0J@I2c1DDNcX5>q>JtB6ZK|MNWxkin(m+n|~zjQ)=ETf?$qEJKKJ*s?t;!PXLSnrZ^ zW>3YKVTHwa*-gmF%>I1bR=cW*+f$?v4&0v@8upDKCPS%dkO!cq>LAq?FgE}}SoOin zkriEE!9&aAJ|2o3HH)5>Q7kRT3)Mt;Rac#A@8ov|6EHU3w_DZgRdvlT98=tbg_lDK zM)G9JHw%7ja`>Gh@f)^I;#lsx%6#oxrFxbxa4VM8-xt;e_E=T~H>BIQV-c58&Qw$+ zj7vLCQx#4kmduDMs~Egbf7*U)W3y}tEI@WsHSl0e$J;Sv>|VC zf0?h1U(10=loX52R3@lpZ|<&m=9ae1K(#$C*LS?IhSURM}j%oA`24 zU2W%%n)YTbgt!;%^6zYhUWQr5 zPi=EJ`K2zj;EwvVJMB&TfDL7t9BueyQl5dR0mu}&saxBQIvxR!6a;}0P7=Sry#^AL zmJmMqcv1k_ck6)Kw%sfib_NljnbnHSpv030(V?eSzV1=f*!us#rSCveXh8~ zQ)2%Z_d3q?qR-xubkT}Y$Z>ckF9nvM6w1TWq~Iby!PR>T`PqdPF%EuvT-Q}FH*6(p zrhv>5ETKX)j7lOtB(LqQ`03U}hac}7ALJMW9c&m*OSo1Bxbi?Wk_cG!eUjPSky$5c zwU^1L4gG>iuX{dyBC{y^{LB=+kVS=MK&?}Sn1c+lJtYTnEqzPJ{j5? zb`hIv9nxWv)zk=cETPIivU|@o7`*(a(#_Oqn>1G=0SaxHI8yJP3^#}@$_?=`7wlu~ zhxD*WrM4+pFfx7;MSQq28PFg;t0nCOOQ>f*@VF(bscyV|vwdgkHeDQkwDtN9k&wfH zWl|V}Nf4qVd~mcOm%cHMe1ECu!LZRu+;}pyJ%;dN%k#MR8gHcB+}AT6kn+`@Q)i|8B{J!pO zbxi-JyTH?@m8yp-W2cN+GzTBw-(wWL_lEx4o0-oh^Vjo`q|xerFP+G&~&YZDrE@9Q*rvRKo?q_`jd`E(5cTvtwT z)hK)cHZVq@T#C%^hh>}x`~4Y72Yl-dKED6nIHJw7 zTPci4PEHn6Xk#vDQPWKw`f0CbL16fCpN_Q))H`)3@u2MTPo1wbSfHp{8~QW4$;+u( zu$3Vhu}t4u4Cet)6vmZ!RU`FKH-(P%?QB?eA(~_!2W)J|4zqTuxH)TwXMUYJZ44!P zG)*Gsp#q0+u#KnB_@MK4kp%6B$LTP=qyrVCv$(z$A9mSmqWI}w%P#W7jlm4&4HPpI zy98hh5P#K~6(SIgCY;5`N=I_cl6J3k+4m5L99UVKAy<5vC@wmBdn6U%Fhqy2ZP;a? zGNg|G-FKE_F!hIT)@zudEd?Haw_51LXOeejIX-1d3=$A&>-p%hPCF$L6ESx77L2bF zaiIF>OWP=%<7?g9+zM|x;EKL;v&MJ88Iyi<7aMp&-SZ-DE*hoa%mi}c$paMKw6rc9 zto_dxtr&>|ctzvj@f$W3_s0mT&Atvo7b~<*S0ZtbF;A=L_<>_o%seaD0ns@t2kvq{ zT#3cj0Ui)|!vDy?@Y``e=M4-rM)YUwkFv&(6H+&%PyBd80?Da9_Un4SJm$G-%_Wid ze3^OB&`-!vA{dJo*#r;kx2P%>Bqv_KT+&14{SevbP-pjwFV(LK$vhZ&fn|}|^NCN3 zNYiNRi@=a+nMyP!!Z5$8TZbKx*uHF^;d3Uza4BIW8vHt;K47T#CxFkgtS|`NdzsW% z;sJ%fHaUZ4z9}*Bbj!v+FQHO$X0j;$%{pc zH^qL`X%;R?GJsj!XKKjEs3VLj0`|kCW|QJjR}>UHIQs1m>-bg9eY34L1|Q?t>?G=> z>jM!eI$03213DoJC^c7i83i%K9%P{?K5X*hthFWkL`C!h!A%7tUIEq=@_WkRj_Gp# z8a-8Ri_>VaZ4p&d!(=p-{axA2++o3xJ(d9EaMLmIF364fW~N6r%MW)Ejzt#kYKfpE zEnB-!o@y;oZz#T0_JuMn9wJ#{mE|IsMLnLlXBJg6J;j8`gR^5IZ)sO9^up6WZ8Qu) zmh6!63Bj9QrjK(jwd58}(|u)Qan)OJhF}}@&akqOCE0-`mQ?pGi#F>*d>8J>jyXgc zX}hz!d&nP)w|mMo14agpcbyE`z!nIPYrDV<*4!LVFjU19o|>KFAzDczm(tlK`cHiH z#x+chsztX`Qt8=|_n?$H!*zUbq_cBVE<`mnzWG|KUABli}*?+5Nn90BWU%%1`})Mn;f2u)jCq{INs_{i^uq zRxaE@yyl)FsPXGE{GOZl21--?!;g4_`F=q;JFevWJ*NZ!e#mb(!H}DoId=2U!0V!!Iob zP?)Rv5u|oW$#?h*>{da3e;)3xf;3zbTNb9WvI(p z_s*gA|NlWEq5h>q z3@}dw@eSgDCKdqo$kl{mpa^onTLm{(FMlHZ6b1ri_@ixHNDuQ*mTxPhK zpaYZvmj1tDxVBwfO^g8wLjXLhzOhRAl_mq!8CUaMfZFfBY5NzlUVw7^Xc!k$27q!P zu-vd8E^u61F+YGVO0RkA%f7iN9Suq$!*heaxhmXz8RW8N^f}7M{}$xh3c4y8ea-_^ zG2*>R*Idv_zU-FE63yorzCd~68+)36Y9IWyH2zzcTvSCqX8|U!;r|b4uFi^n)XQas z<8uskf&UERT9^EgjJ&8=e9i&@U<>{SG(Yu=L0icWh>J48pb%6-{~5&Jy5yoPFDQ+e z@P9ya_YX<1%PzSn!3zp8^WQ;S>yqpAcF%d9i~I*JxmJDmvWG6J-kuWy0Kq^N(HrYp zE=a&$X1FXodrlD|_FpkvTS-^dU(ZnhfT;U74|BD1`@wKg!xfZ4>A`=+aIHhG3bBI1 z;EVrzn7@%_1#KEvwG2UxtH}Ig<3HteE}S3yl7_kP>i?u{2ugTW)DV>L%fBT&mpHs^ z?4l$gsIfP|bCrMiwElF*AI8oF3PCMirzUuAQyCa<`L8VgI-B_A{9mv9owgt-)eom% z)D}Ev0sub#TdKcR8U(d{otoacbrbo2>5)HUP=ER3&);c5U;m{_1j=(&Tko6(09gG^ zo@+EOu2VhxAC&e$S+CRBJEsj+_&wiU)e!i5R1g)nYrT3^aqpZH0H6UXYyYcu|7UGp zQrEi<^WsJ9YZkvWyd@bE|3V!EwwyMAB#q&s~zZ-~jE)}_!@~WQS zIU_Jhn%a#~g2rS0y*vL_-4FChx~l63%3Sd;m@i6e{NYeggI5KrKn-dG({KFKA?BjN zYld!6^VezkoCCbmzajG=11+fa>!eH0tqTHE(fsCzzc_w^n!c)Oac&p@NCoO;|E}qa zqavv7>(mR*t=}{IZQEA|I#BahZ-Ad02MT;x-jw-^BOEBf)oZ1o1PQjkO>ku}0=0hi zt{A9wF^8M64l=@k8ow^I{@i@H+ix2O89PAjUX8duw+g&6_xy(J{t|%&wS6@h7u2@0 e*A3bR9SUS6p@6pmfeE02-|W=DbVj~Ee*1rA5$4VS literal 0 HcmV?d00001 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 4a7e3c32..8c778061 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -152,7 +152,8 @@ tcl::namespace::eval textblock { hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} } proc use_hash {args} { - set argd [punk::args::get_by_id ::textblock::use_hash $args] + #set argd [punk::args::get_by_id ::textblock::use_hash $args] + set argd [punk::args::parse $args withid ::textblock::use_hash] variable use_hash if {![dict exists $argd received hash_algorithm]} { return $use_hash @@ -4143,7 +4144,8 @@ tcl::namespace::eval textblock { proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + #set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opts [dict get [punk::args::parse $args withid ::textblock::periodic] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -7913,7 +7915,8 @@ tcl::namespace::eval textblock { #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { #as frame is called a lot within table building - checking args can have a *big* impact on final performance. - set argd [punk::args::get_by_id ::textblock::frame $args] + #set argd [punk::args::get_by_id ::textblock::frame $args] + set argd [punk::args::parse $args withid ::textblock::frame] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8650,7 +8653,7 @@ tcl::namespace::eval textblock { size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id ::textblock::gcross $args] + set argd [punk::args::parse $args withid ::textblock::gcross] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.5.tm new file mode 100644 index 00000000..7ff93c3e --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.5.tm @@ -0,0 +1,6973 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# 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 tomlish 1.1.5 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.5] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #default interp recursionlimit of 1000 is insufficient to pass 1000 deep nested structures as in certain toml tests. + #e.g https://github.com/iarna/toml-spec-tests/tree/latest/values + #1000 seems deep for a 'configuration' format - but toml sometimes used for other serialisation purposes. + #todo - review + set existing_recursionlimit [interp recursionlimit {}] + if {$existing_recursionlimit < 5000} { + interp recursionlimit {} 5000 + } + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + #This reordering idea is complicated by the nature of tablearrays - especially as a table header references last tablearrayname, + # and duplicate table headers are allowed in that context. + #e.g + #[[fruits]] + # name="apple" + # [fruits.metadata] + # id=1 + # + #[unrelated1] + # + #[[fruits]] + # name="pear" + # + #[unrelated2] + # silly="ordering" + # + #[fruits.metadata] + #id=2 + #The TABLEARRAY record can't be completely selfcontained on the default parsing mechanism - because it is legal (though not recommended) to have unrelated tables in between. + #If we were to 'insert' later related records (such as the 2nd [fruits.metadata] above) into the TABLEARRAY structure - then, even though it might produce 'nicer' toml, + # we would lose roundtripability toml->tomlish->toml + # ----------------------------------------------------- + #REVIEW + #todo - some sort of 'normalize'/'grouping' function on tomlish that at least makes records self-contained, and perhaps then (optionally) reorders resulting records sensibly. + #such a function on the tomlish may work - although it would be unwise to duplicate the validation aspects of to_dict + #The most practical way might be to use to_dict followed by from_dict - but that would lose comment info and formatting. + #In the above example - The decision by the toml author to put [unrelated1] between related tablearrays should be respected, + #but the positioning of [unrelated2] between a tablearray and one of its contained tables is suspect. + #Both [fruits.metadata] table records should theoretically be added as children to their corresponding [[fruits]] tablearray record in the tomlish. (just as their name keys are) + # ----------------------------------------------------- + + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE TABLEARRAY WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #removed - ANONTABLE + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + #todo - configurable - allow empty string for 'unlimited' + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + #find the value (or 2 values if space separated datetime - and stitch back into one) + # 3 is the earliest index at which the value could occur (depending on whitespace) + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keys are lists {parenttable subtable etc} corresponding to parenttable.subtable.etc + } + set sublist [lrange $keyval_element 2 end] + + set values [list] + set value_posns [list] + set posn 0 + foreach sub $sublist { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + lappend values $sub + lappend value_posns $posn + } + default {} + } + incr posn + } + switch -- [llength $values] { + 0 { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + 1 { + lassign [lindex $values 0] type value + } + 2 { + #validate than exactly single space was between the two values + lassign $value_posns p1 p2 + if {$p2 != $p1 +2} { + #sanity check + #can probably only get here through manual manipulation of the tomlish list to an unprocessable form + error "tomlish KEY appears to have more than one part - but not separated by whitespace - invalid '$keyval_element'" + } + set between_token [lindex $sublist $p1+1] + if {[lindex $between_token 1] ne " "} { + error "tomlish KEY in 2 parts is not separated by a single space - cannot consider for datetime '$keyval_element'" + } + lassign [lindex $values 0] type_d1 value_d1 + lassign [lindex $values 1] type_d2 value_d2 + if {$type_d1 ne "DATETIME" || $type_d2 ne "DATETIME"} { + error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" + } + set type DATETIME + set value "${value_d1}T${value_d2}" + } + default { + error "tomlish Found multiple value elements in KEY, expected one. (or 2 for space-separated datetime) '$keyval_element'" + } + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [ list [lindex $values 0] ]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole [lindex $values 0] (type val) - not just the $value! + set prev_tablenames_info $tablenames_info + set tablenames_info [dict create] + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + set tablenames_info $prev_tablenames_info + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + package require dictn + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + + #Declaring, Creating, and Defining Tables + #https://github.com/toml-lang/toml/issues/795 + #(update - only Creating and Defining are relevant terminology) + + #review + #tablenames_info keys type created, defined, createdby, definedby, closedby ??? review keys + # [tname] = header_table [[tname]] = header_tablearray + + #consider the following 2 which are legal: + #[table] #'table' created, defined=open type header_table + #x.y = 3 + #[table.x.z] #'table' defined=closed closedby={header_table table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k= 22 + # #'table.x.z' defined=closed closedby={eof eof} + + #equivalent datastructure + + #[table] #'table' created, defined=open definedby={header_table table} + #[table.x] #'table' defined=closed closedby={header_table table.x}, 'table.x' created defined=open definedby={header_table table.x} + #y = 3 + #[table.x.z] #'table.x' defined=closed closedby={header_table table.x.z}, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k=22 + + #illegal + #[table] #'table' created and defined=open + #x.y = 3 #'table.x' created first keyval pair defined=open definedby={keyval x.y = 3} + #[table.x.y.z] #'table' defined=closed, 'table.x' closed because parent 'table' closed?, 'table.x.y' cannot be created + #k = 22 + # + ## - we would fail on encountering table.x.y because only table and table.x are effectively tables - but that table.x is closed should be detected (?) + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + + + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keyed on tablepath each of which is a list such as {config subgroup etc} (corresponding to config.subgroup.etc) + } + + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [tomlish::to_dict::get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #tleaf -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set tleaf [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set tleaf [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $tleaf]} { + error "Duplicate key '$table_hierarchy $tleaf'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + dictn incr tablenames_info [list $table_hierarchy seencount] + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + set t [list {*}$table_hierarchy $tleaf] + dictn incr tablenames_info [list $t seencount] + dictn set tablenames_info [list $t closed] 1 + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } + + } + TABLEARRAY { + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + + set NEST_DICT [dict create] ;#first blush attempt at referencing supertable tablearrays + set tablearrayname [lindex $item 1] + log::debug "---> to_dict processing item TABLENAME (name: $tablearrayname): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablearrayname true] ;#true to normalize + #we expect repeated tablearray entries - each adding a sub-object to the value, which is an array/list. + #tablearrayname is likely to appear multiple times - so unlike a TABLE we don't check for 'defined' for the full name as an indicator of a problem + set supertable [list] + ############## + # [[a.b.c.d]] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of tablearray name $tablearrayname already has data but doesn't appear to be a table - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_supertable_keycollision + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } else { + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #REVIEW!! + # what happens with from_toml {[[a.b.c]]} {[[a]]} ??? + dictn set tablenames_info [list $supertable type] header_table ;#how do we know it's not going to be a tablearray? + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } else { + #supertable has already been created - and maybe defined - but even if defined we can add subtables unless it is of type itable + #but if it's a tablearray - we need to point to the most 'recently defined table element of the array' + #(another way of saying last member of that array)?? + set supertype [dictn get $tablenames_info [list $supertable type]] + if {$supertype eq "header_tablearray"} { + puts stdout "todict!!! TABLEARRAY nesting required for supertable [join $supertable .]" + puts stdout "todict!!! todo.." + #how to do multilevel nesting?? + set EXISTING_SUPERARRAY_ELEMENTS [dict get $datastructure {*}$supertable value] + dict set NEST_DICT $supertable $EXISTING_SUPERARRAY_ELEMENTS + puts stdout "todict!!! supertable '[join $supertable .]' elements $EXISTING_SUPERARRAY_ELEMENTS" + } + } + } + # + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + #first encounter of this tablearrayname + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[[a]]} + set msg "Cannot create tablearray name $tablearrayname. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_direct_keycollision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no collision - we can create the tablearray and the array in the datastructure + dictn set tablenames_info [list $norm_segments type] header_tablearray + dict set datastructure {*}$norm_segments [list type ARRAY value {}] + set ARRAY_ELEMENTS [list] + } else { + #we have a table - but is it a tablearray? + set ttype [dictn get $tablenames_info [list $norm_segments type]] + #use a tabletype_unknown type for previous 'created' only tables? + if {$ttype ne "header_tablearray"} { + set msg "tablearray name $tablearrayname already appears to be already created as a table not a tablearray - invalid?" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #add to array + #error "add_to_array not implemented" + #{type ARRAY value } + set ARRAY_ELEMENTS [dict get $datastructure {*}$norm_segments value] + } + + + set object [dict create] ;#array context equivalent of 'datastructure' + set objectnames_info [dict create] ;#array contex equivalent of tablenames_info + + #add to ARRAY_ELEMENTS and write back in to datastructure. + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #MAINTENANCE: temp copy from TABLE + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + #set supertable $norm_segments + set supertable [list] ;#disconnect from main structure - each array element is a new context for key paths! + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey '$dottedkeyname' kv: $keyval_dict" + #dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #wrong + #TODO!!!!!!!!!!!!! + #lappend ARRAY_ELEMENTS [list $dottedkeyname $keyval_dict] + dict set object $dottedkeyname $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + TABLE { + #we should be able to process tablearray subtables either as part of the tablearray record, or independently. + #(or even a mixture of both, although that is somewhat an edge case) + #[[fruit]] + #x=1 + # [fruit.metadata] + # [fruit.otherdata] + + #when processing a dict destined for the above - the tomlish generator (e.g from_dict) + #should create as 1 or 3 records (but could create 2 records if there was an unrelated table in between the subtables) + #choices: all in tablearray record, tablearray + 1 or 2 table records. + # + #We are going the other way here - so we just need to realize the list of tables 'belonging' to this tablearray might not be complete. + # + #the subtable names must be prefixed with the tablearray - we should validate that for any contained TABLE records + + } + default { + error "Sub element of type '$type' not understood in tablearray context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #todo? + ##end of TABLE record - equivalent of EOF or next header - close off the dottedtables + #foreach dtablepath $dottedtables_defined { + # dictn set tablename_info [list $dtablepath defined] closed + #} + + if {[dict size $NEST_DICT]} { + puts "reintegrate?? $NEST_DICT" + #todo - more - what if multiple in hierarchy? + dict for {superpath existing_elements} $NEST_DICT { + #objects stored directly as dicts in ARRAY value + set lastd [lindex $existing_elements end] + #insufficient.. + #dict set lastd [lindex $norm_segments end] [list type ITABLE value $object] + dict set lastd [lindex $norm_segments end] $object + #set lastd [dict merge $lastd $object] + lset existing_elements end $lastd + dict set datastructure {*}$superpath [list type ARRAY value $existing_elements] + } + } else { + #lappend ARRAY_ELEMENTS [list type ITABLE value $object] + lappend ARRAY_ELEMENTS $object + dict set datastructure {*}$norm_segments [list type ARRAY value $ARRAY_ELEMENTS] + } + } + TABLE { + set tablename [lindex $item 1] + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + #As our TABLE record contains all it's child DOTTEDKEY records - this should be equivalent to setting them as defined at EOF or next header. + + log::debug "---> to_dict processing item TABLE (name: $tablename): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablename true] ;#true to normalize + + set T_DEFINED [dictn getdef $tablenames_info [list $norm_segments defined] NULL] + if {$T_DEFINED ne "NULL"} { + #our tablename e.g [a.b.c.d] declares a space to 'define' subkeys - but there has already been a definition space for this path + set msg "Table name $tablename has already been directly defined in the toml data. Invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + + + set name_segments [::tomlish::to_dict::tablename_split $tablename 0] ;#unnormalized e.g ['a'."b".c.d] -> 'a' "b" c d + #results of tablename_split 0 are 'raw' - ie some segments may be enclosed in single or double quotes. + + + set supertable [list] + ############## + # [a.b.c.d] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of table name $tablename already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] header_table + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } else { + #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable + + } + } + #table [a.b.c.d] hasn't been defined - but may have been 'created' already by a longer tablename + # - or may have existing data from a keyval + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[a]} + set msg "Cannot create table name $tablename. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablename_keyval_collision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no data or previously created table + dictn set tablenames_info [list $norm_segments type] header_table + + #We are 'defining' this table's keys and values here (even if empty) + dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here + } + dictn set tablenames_info [list $norm_segments defined] open + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> normalized table key hierarchy : $norm_segments" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + set supertable $norm_segments + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey $dottedkeyname kv: $keyval_dict" + dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #end of TABLE record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dictn set tablename_info [list $dtablepath defined] closed + } + + + #review??? + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + #take a raw string and classify: result is a 2 element list comprised of KEY|SQKEY|DQKEY and the value being the appropriate inner string + proc _from_dict_classify_key {rawval} { + if {![::tomlish::utils::is_barekey $rawval]} { + #requires quoting + # + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + # + #we'll use a basic mechanisms for now to determine the type of quoting + # - whether it has any single quotes or not. + # (can't go in an SQKEY) + # - whether it has any chars that require quoting when in a Bstring + # (if so - then its visual representation might be unsuitable for a key in a toml text file, so escape and put in DQKEY instead of literal SQKEY) + #todo - more? + #REVIEW - the backslash might often be in things like a regex or windows path - which is often better expressed in a literal SQKEY + # from literal examples: + # 'c:\Users\nodejs\templates' + # '<\i\c*\s*>' + #If these are in *keys* our basic test will express these as: + # "c:\\Users\\nodejs\\templates" + # "<\\i\\c*\\s*>" + # This still works - but a smarter test might determine when SQKEY is the better form? + #when coming from external systems - can we even know if the value was already escaped? REVIEW + #Probably when coming from json - we know it's already escaped - and so we build our dict converting keys to unescaped + #TODO - clarify in documentation that keys resulting from to_dict are in 'normalized' (unescaped) form + # + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + set k_escaped [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + if {[string length $k_escaped] != [string length $rawval]} { + #escaping made a difference + set has_escape_requirement 1 + } else { + set has_escape_requirement 0 + } + if {[string first ' $rawval] >=0 || $has_escape_requirement} { + #basic string + # (any ANSI SGR sequence will end up here in escaped form ) + return [list DQKEY $k_escaped] + } else { + #literal string + return [list SQKEY $rawval] + } + } else { + return [list KEY $rawval] + } + } + + #the quoting implies the necessary escaping for DQKEYs + proc _from_dict_join_and_quote_raw_keys {rawkeylist} { + set result "" + foreach rk $rawkeylist { + lassign [_from_dict_classify_key $rk] type val + switch -- $type { + SQKEY { + append result "'$val'." + } + DQKEY { + append result "\"$val\"." + } + KEY { + append result "$val." + } + } + } + return [string range $result 0 end-1] + } + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + set K_PART [_from_dict_classify_key $k] ;#get [list SQKEY ] + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + set result [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + #(SQKEY & DQKEY do not have the enclosing quotes in their returned val) + #if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + # set VK_PART [list SQKEY $vk] + #} else { + # set VK_PART [list KEY $vk] + #} + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + #REVIEW - we could detect if value is an array of objects, + #and depending on parent context - emit a series of TABLEARRAY records instead of a DOTTEDKEY record containing an ARRAY of objects + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + + #we can't just join normalized keys - need keys with appropriate quotes and escapes + #set tname [join [list {*}$keys $vk] .] ;#WRONG + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list $K_PART] = ITABLE {NEWLINE lf} + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + lappend result TABLE $tname {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list $VK_PART] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + #review - where to make decision on + # DOTTEDKEY containing array of objs + #vs + # list of TABLEARRAY records + #At least for the top + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + error todo + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like tentative_accum_squote need to do their own append + switch -exact -- $tokenType { + tentative_accum_squote { + #should only apply within a multiliteral + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-squote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-squote-space { + } + default { + error "--- unexpected popped due to tentative_accum_squote but came from state '$prevstate' should have been trailing-squote-space" + } + } + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type single_squote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + MULTILITERAL { + #empty + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + ''''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "''"] + } + MULTILITERAL { + lappend v($parentlevel) [list LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + } + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + tentative_accum_dquote { + #should only apply within a multistring + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the trailing-dquote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-dquote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-dquote-space { + } + default { + error "--- unexpected popped due to tentative_accum_dquote but came from state '$prevstate' should have been trailing-dquote-space" + } + } + switch -- $tok { + {"} { + tomlish::parse::set_token_waiting type single_dquote value $tok complete 1 startindex [expr {$i -1}] + } + {""} { + #review - we should perhaps return double_dquote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_dquote value "" complete 1 startindex [expr {$i - 2}] + } + {"""} { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 3}] + } + {""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left dquote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {"}] + } + MULTISTRING { + #empty + lappend v($parentlevel) [list STRINGPART {"}] + } + default { + error "--- don't know how to integrate extra trailing dquote with data $v($parentlevel)" + } + } + } + {"""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 dquotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {""}] + } + MULTISTRING { + lappend v($parentlevel) [list STRINGPART {""}] + } + default { + error "--- don't know how to integrate extra trailing 2 dquotes with data $v($parentlevel)" + } + } + } + } + } + triple_dquote { + #presumably popping multistring-space + ::tomlish::log::debug "---- triple_dquote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTISTRING { + lappend merged $part + } + STRINGPART { + if {$lasttype eq "STRINGPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + CONT - WS { + lappend merged $part + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_dquote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g tentative_accum_squote does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + tentative_trigger_squote - tentative_trigger_dquote { + #### this startok will always be tentative_accum_squote/tentative_accum_dquote starting with one accumulated squote/dquote + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + single_squote { + #JMN - REVIEW + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERALPART + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + triple_dquote { + set v($nest) [list MULTISTRING] ;#container for NEWLINE,STRINGPART,CONT + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + tablename { + #note: we do not use the output of tomlish::to_dict::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names from + # a structural perspective. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$trimtable'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablearrayname: '$trimtable'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + #puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + #puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + single_dquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + dquoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + multistring-space { + lappend v($nest) [list STRINGPART {"}] + #may need to be joined on pop if there are neighbouring STRINGPARTS + } + default { + error "---- single_dquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_dquote { + #leading extra quotes - test: toml_multistring_startquote2 + switch -exact -- $prevstate { + itable-keyval-value-expected - keyval-value-expected { + puts stderr "tomlish::decode::toml double_dquote TEST" + #empty string + lappend v($nest) [list STRINGPART ""] + } + multistring-space { + #multistring-space to multistring-space + lappend v($nest) [list STRINGPART {""}] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + + } + single_squote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from tentative_accum_squote pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- single_squote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + enddquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + untyped_value { + #would be better termed unclassified_value + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + unset -nocomplain tag + if {$tok in {true false}} { + set tag BOOL + } else { + if {[::tomlish::utils::is_int $tok]} { + set tag INT + } else { + if {[string is integer -strict $tok]} { + #didn't qualify as a toml int - but still an int + #probably means is_int is limiting size and not accepting bigints (configurable?) + #or it didn't qualify due to more than 1 leading zero + #or other integer format issue such as repeated underscores + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. (looks close to being an int. Formatting or range issue?) [tomlish::parse::report_line] (no space level change)" + } else { + if {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok] || [::tomlish::utils::is_timepart $tok]} { + #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a localdate + #e.g x= 2025-01-01 02:34Z + #The to_dict validation will catch an invalid standaline timepart, or combine with leading date if applicable. + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + } + } + } + #assert either tag is set, or we errored out. + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [dict create] + dict set Bstring_control_map \b {\b} + dict set Bstring_control_map \n {\n} + dict set Bstring_control_map \r {\r} + dict set Bstring_control_map \" {\"} + dict set Bstring_control_map \x1b {\e} ;#In spec it's included in the list of 'must be escaped', as well as the 'convenience' escapes - so we make it go both ways. + dict set Bstring_control_map \\ "\\\\" + + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + #8 = \b - already in list. + #built the remainder whilst checking for entries already hardcoded above -in case more are added to the hardcoded list + for {set cdec 0} {$cdec <= 7} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + # \u007F = 127 + dict set Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + #plus \e for \x1b? + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + append buffer {"} + } + b - t - n - f - r { + append buffer [subst -nocommand -novariable "\\$c"] + } + e { + append buffer \x1b + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\$c" + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] ;#0b101 etc covered by a-f + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + #(but still allowing 0 -0 +0) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. (excludes also +++1 etc) + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + + #------------------------------------------- + #unclear if a 'digit' includes the type specifiers x b o + #we assume the 0x 0b 0o are NOT counted as digits - as underscores here would seem + #to be likely to cause interop issues with other systems + #(e.g tcl allows 0b1_1 but not 0b_11) + #Most of this structure would be unnecessary if we could rely on string::is::integer understanding underscores (9+?) + #we still need to support earlier Tcl for now though. + + #first rule out any case with more than one underscore in a row + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_0xFF + if {[string index $utest 0] eq "_"} { + return 0 + } + if {[string range $utest 0 1] in {0x 0b 0o}} { + set testnum [string range $utest 2 end] + } else { + set testnum $utest + #exclude also things like 0_x 0___b that snuck past our prefix test + if {![string is digit -strict [string map {_ ""} $testnum]]} { + return 0 + } + #assert - only digits and underscores in testnum + #still may have underscores at each end + } + #assert testnum is now the 'digits' portion of a , 0x 0b 0o number + #(+ and - already stripped) + #It may still have chars unsuitable for its type - which will be caught by the string::is::integer test below + if {[string length $testnum] != [string length [string trim $testnum _]]} { + #had non-inner underscores in 'digit' part + return 0 + } + #assert str only has solo inner underscores (if any) between 'digits' + #------------------------------------------- + + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + + + + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements by default (for now) + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + #some question around implementations allowed to use lower values such as 2^31 on some systems? + if {$::tomlish::max_int ne "" && $numeric_value > $::tomlish::max_int} { + return 0 + } + if {$::tomlish::min_int ne "" && $numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + #note - Tcl's string is double will return true also for the subset of float values which are integers + #This function is to determine whether it matches the Toml float concept - so requires a . or e or E + proc is_float {str} { + #vip greenlight known literals, don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + #doorcheck the basics for floatiness vs members of that rival gang - ints + if {![regexp {[.eE]} $str]} { + #could be an integer - which isn't specifically a float for Toml purposes. + return 0 + } + + + #patdown for any contraband chars + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + + #all characters in legal range + + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + + #Early Toml spec also disallowed leading zeros in the exponent part(?) + #... this seems less interoperable anyway (some libraries generate leading zeroes in exponents) + #we allow leading zeros in exponents here. + + #Check for leading zeros in main part + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #----------------------------------------- + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_" || [string index $str end] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_ + if {[string index $utest 0] eq "_"} { + return 0 + } + #----------------------------------------- + + #decimal point, if used must be surrounded by at least one digit on each side + #e.g 3.e+20 also illegal + set dposn [string first . $str] + if {$dposn > -1 } { + set d3 [string range $str $dposn-1 $dposn+1] + if {![string is integer -strict [string index $d3 0]] || ![string is integer -strict [string index $d3 2]]} { + return 0 + } + } + #we've already eliminated leading/trailing underscores + #now ensure each inner underscore is surrounded by digits + if {[regexp {_[^0-9]|[^0-9]_} $str]} { + return 0 + } + + #strip underscores for tcl double check so we can support < tcl 9 versions which didn't allow underscores + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + #All good - seems to be a toml-approved float and not an int. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_datepart {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_localdate {str} { + is_datepart $str + } + proc is_timepart {str} { + set numchars [tcl::string::length $str] + #timepart can have negative or positive offsets so - and + must be accepted + if {[regexp -all {[zZt0-9\-\+\.:]} $str] == $numchars} { + #todo + #basic check that we have leading 2dig hr and 2dig min separated by colon + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}[^0-9]{1}.*$} $str]} { + #nn:nn or nn:nnX.* where X is non digit + return 0 + } + return 1 + } else { + return 0 + } + } + proc is_localtime {str} { + #time of day without any relation to a specific day or any offset or timezone + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\.:]} $str] == $numchars} { + #todo + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}:[0-9]{2}([.][0-9]*){0,1}$} $str]} { + #hh:mm or hh:mm:ss or hh:mm::ss.nnn + return 0 + } + return 1 + } else { + return 0 + } + } + + #review + proc is_datetime {str} { + #Essentially RFC3339 formatted date-time - but: + #1) allowing seconds to be omitted (:00 assumed) + #2) T may be replaced with a single space character TODO - parser support for space in datetime! + # (RFC 3339 allows space instead of T also - but doesn't specify it *must* be a single space) + + #toml-lint @2025-04 doesn't accept t for T or z for Z - but RFC3339 does + #toml spec doesn't clarify - we will accept + + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 not ok - 2024T not accepted by tomlint why? + # 02:00 ok + # 02:00:00.5 ok + # 1:00 - not ok - RFC3339 requires 2-digit hr,min,sec + + #toml-lint.com accepts 2025-01 + + if {[string length $str] < 5} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\ \-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + if {[regexp -all {\ } $str] > 1} { + #only a single space is allowed. + return 0 + } + #If we get a space - it is only valid as a convience to represent the T separator + #we can normalize by converting to T here before more tests + set str [string map {" " T t T} $str] + #a further sanity check on T + if {[regexp -all {T} $str] > 1} { + return 0 + } + + #!todo - use full RFC 3339 parser? + #!todo - what if the value is 'time only'? + + if {[string first T $str] > -1} { + lassign [split $str T] datepart timepart + if {![is_datepart $datepart]} { + return 0 + } + if {![is_timepart $timepart]} { + return 0 + } + } else { + #either a datepart or a localtime + #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day + # without any relation to a specific day or any offset or timezone." + if {!([is_datepart $str] || [is_localtime $str])} { + return 0 + } + } + + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # array-value-expected,keyval-value-expected,itable-keyval-value-expected, keyval-syntax, + # dquoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # xxx_value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + #--------------------------------------------------------- + #WARNING + #The stateMatrix implementation here is currently messy. + #The code is a mixture of declarative via the stateMatrix and imperative via switch statements during PUSH/POP/SAMESPACE transitions. + #This means the state behaviour has to be reasoned about by looking at both in conjuction. + #--------------------------------------------------------- + + #xxx-space vs xxx-syntax inadequately documented - TODO + + #review - out of date? + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> keyval-value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXsingle_dquote "quoted-key"\ + XXXsingle_squote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + enddquote "err-state"\ + endsquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-untyped-sequence" note "possible datetime datepart"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"} + + #untyped_value sequences without intervening comma are allowed for datepart timepart + #we will produce tomlish with missing SEPS and to_dict must validate whether 2 adjacent barekeys are valid + dict set stateMatrix\ + keyval-untyped-sequence {\ + whitespace "keyval-untyped-sequence"\ + untyped_value {TOSTATE "keyval-tail"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + #2025 - no leading-squote-space - only trailing-squote-space. + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + + #itable-space/ curly-syntax : itables + # x={y=1,} + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #we don't get single_squote etc here - instead we get the resulting squotedkey token + + + # ??? review - something like this + # + # x={y =1,} + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace {TOSTATE "itable-keyval-syntax"}\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal {TOSTATE "itable-keyval-value-expected"}\ + newline "err-state"\ + eof "err-state"\ + } + + # x={y=1} + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + single_dquote {TOSTATE "string-state" returnstate itable-val-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + single_squote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + #double_squote not currently generated by _start_squote_sequence - '' processed as single_squote to literal-state just like 'xxx' + # review + # double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"} + + + + # x={y=1,z="x"} + #POPSPACE is transition from itable-keyval-space to parent itable-space + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + newline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + comment "itable-val-tail"\ + eof "err-state"\ + } + # XXXnewline "POPSPACE" + # We shouldn't popspace on newline - as if there was no comma we need to stay in itable-val-tail + # This means the newline and subsequent whitespace, comments etc become part of the preceeding dottedkey record + #e.g + # x = { + # j=1 + # #comment within dottedkey j record + # , # comment unattached + # #comment unattached + # k=2 , #comment unattached + # l=3 #comment within l record + # , m=4 + # #comment associated with m record + # + # #still associated with m record + # } + ## - This doesn't quite correspond to what a user might expect - but seems like a consistent mechanism. + #The awkwardness is because there is no way to put in a comment that doesn't consume a trailing comma + #so we cant do: j= 1 #comment for j1 , + # and have the trailing comma recognised. + # + # To associate: j= 1, #comment for j1 + # we would need some extra processing . (not popping until next key ? extra state itable-sep-tail?) REVIEW - worth doing? + # + # The same issue occurs with multiline arrays. The most natural assumption is that a comment on same line after a comma + # is 'associated' with the previous entry. + # + # These comment issues are independent of the data dictionary being generated for conversion to json etc - as the comments don't carry through anyway, + # but are a potential oddity for manipulating the intermediate tomlish structure whilst attempting to preserve 'associated' comments + # (e.g reordering records within an itable) + #The user's intention for 'associated' isn't always clear and the specs don't really guide on this. + + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + eof "err-state"\ + newline "err-state"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - multiline itables appear to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + #dict set stateMatrix\ + # array-space {\ + # whitespace "array-space"\ + # newline "array-space"\ + # untyped_value "SAMESPACE"\ + # startarray {PUSHSPACE "array-space"}\ + # endarray "POPSPACE"\ + # startinlinetable {PUSHSPACE itable-space}\ + # single_dquote "string-state"\ + # single_squote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + # comma "array-space"\ + # comment "array-space"\ + # eof "err-state-array-space-got-eof"\ + # } + + ## array-space ## + set aspace [dict create] + dict set aspace whitespace "array-space" + dict set aspace newline "array-space" + #dict set aspace untyped_value "SAMESPACE" + dict set aspace untyped_value "array-syntax" + dict set aspace startarray {PUSHSPACE "array-space"} + dict set aspace endarray "POPSPACE" + dict set aspace single_dquote {TOSTATE "string-state" returnstate array-syntax} + dict set aspace triple_dquote {PUSHSPACE "multistring-space" returnstate array-syntax} + dict set aspace single_squote {TOSTATE "literal-state" returnstate array-syntax} + dict set aspace triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax} + dict set aspace startinlinetable {PUSHSPACE itable-space} + #dict set aspace comma "array-space" + dict set aspace comment "array-space" + dict set aspace eof "err-state-array-space-got-eof" + dict set stateMatrix array-space $aspace + + #when we pop from an inner array we get to array-syntax + #e.g {x=[[]] ??? + set tarntail [dict create] + dict set tarntail whitespace "tablearrayname-tail" + dict set tarntail newline "err-state" + dict set tarntail comment "err-state" + dict set tarntail eof "err-state" + dict set tarntail endtablename "tablearray-tail" + dict set stateMatrix tablearrayname-tail $tarntail + + #review - somewhat counterintuitive...? + # [(starttablearrayname) (endtablearrayname] + # [(starttablename) (endtablename)] + + # [[xxx]] ??? + set tartail [dict create] + dict set tartail whitespace "tablearray-tail" + dict set tartail newline "table-space" + dict set tartail comment "tablearray-tail" + dict set tartail eof "end-state" + dict set stateMatrix tablearray-tail $tartail + + + + + + + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #use dict set to add values so we can easily add/remove/comment lines + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions [dict create] + dict set spacePushTransitions keyval-space keyval-syntax + dict set spacePushTransitions itable-keyval-space itable-keyval-syntax + dict set spacePushTransitions array-space array-space + dict set spacePushTransitions table-space tablename-state + #dict set spacePushTransitions #itable-space itable-space + + #Pop to, next + variable spacePopTransitions [dict create] + dict set spacePopTransitions array-space array-syntax + + + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from keyval-value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions [dict create] + #JMN test + #dict set spaceSameTransitions array-space array-syntax + + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + set popfromspace_info [spacestack peek] + set popfromspace_state [dict get $popfromspace_info state] + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + ::tomlish::log::debug "--->> zeropoppushspace goNextState RECURSE. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + #for multiliteral, multistring - data and/or end + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo token beginning with underscore - never returned to state machine - review + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\{" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename - tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow: + # table -> starttablearrayname + # tablearray -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + array-syntax - array-space { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-tail { + #[[xxx] + set_tokenType "endtablename" + #sequence: starttablename -> starttablearrayname -> endtablearrayname -> endtablename + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + string - dquotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + #for within multiliteral + #short tentative_accum_squote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_squote is multisquote + 2 = 5 + #return tok with value ''''' + return 1 + } + } + tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multiliteral + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + #if there are more than 3 leading squotes we also enter multiliteral space and the subsequent ones are handled + #by the tentative_accum_squote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 squotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to a tentative_accum_squote token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #barekeys now support all sorts of unicode letter/number chars for other cultures + #but not punctuation - not even for those of Irish heritage who don't object + #to the anglicised form of some names. + # o'shenanigan seems to not be a legal barekey + #The Irish will have to use an earlier form Ó - which apparently many may prefer anyway. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading squote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_squote token or triple_squote token + #It currently doesn't trigger double_squote token + #(handle '' same as 'x' ie produce a single_squote and go into processing literal) + #review - producing double_squote for empty literal may be slightly more efficient. + #This token is not used to handle squote sequences *within* a multiliteral + set_tokenType "_start_squote_sequence" + set tok "'" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_squote" ;#trigger tentative_accum_squote + set tok "'" + return 1 + } + table-space - itable-space { + #tests: squotedkey.test squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXtable-space - XXXitable-space { + #future - could there be multiline keys? MLLKEY, MLBKEY ? + #this would (almost) allow arbitrary tcl dicts to be stored in toml (aside from escaping issues) + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + #@2025 ABNF for toml mentions key, simple-key, unquoted-key, quoted-key and dotted-key + #where key is simple-key or dotted-key - no MLL or MLB components + #the spec states solution for arbitrary binary data is application specific involving encodings + #such as hex, base64 + set_tokenType "_start_squote_sequence" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType "tablename" + append tok "'" + } + tablearrayname-state { + set_tokenType "tablearrayname" + append tok "'" + } + literal-state { + #shouldn't get here? review + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType "literal" + incr -1 + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + #error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + dottedkey-space { + set_tokenType "squotedkey" + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + tentative_accum_dquote { + #within multistring + #short tentative_accum_dquote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_dquote is multidquote + 2 = 5 + #return tok with value """"" + return 1 + } + } + _start_dquote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multistring + #switch? + append tok $c + set_tokenType triple_dquote + return 1 + } + default { + #if there are more than 3 leading dquotes we also enter multistring space and the subsequent ones are handled + #by the tentative_accum_dquote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 dquotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_dquote_sequence'" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + incr i -1 ;#throw the {"} back to loop - will be added to a tentative_accum_dquote token for later processing + return 1 + } + } + whitespace { + #assert: had_slash will only ever be true in multistring-space + if {$had_slash} { + incr i -2 + return 1 + } else { + #end whitespace token - throw dq back for reprocessing + incr i -1 + return 1 + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type enddquote value {"} complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading dquote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_dquote token or triple_dquote token + #It currently doesn't trigger double_dquote token + #(handle "" same as "x" ie produce a single_dquote and go into processing string) + #review - producing double_dquote for empty string may be slightly more efficient. + #This token is not used to handle dquote sequences once *within* a multistring + set_tokenType "_start_dquote_sequence" + set tok {"} + } + multistring-space { + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + } else { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_dquote" ;#trigger tentative_accum_dquote + set tok {"} + return 1 + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + default { + error "tomlish Unexpected dquote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0 + append tok $c + } + string - comment - dquotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok = + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + #multiliteral or multistring + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + #review + if {$had_slash} { + incr i -2 + } else { + incr i -1 + } + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $c + } + string - dquotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART xxx WS " " + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + append tok $c + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #assert - tok will be one or two squotes only + #A toml literal probably isn't allowed to contain this + #but we will parse and let the validator sort it out. + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart { + append tok $c + } + string - stringpart { + append tok $c + } + default { + #state machine will generally not have entry to accept bom - let it crash + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + multistring-space { + set_tokenType "stringpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + set tok \\$c + } else { + set tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "literal" + set tok "" + return 1 + + ##review + #set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + #set_tokenType "literal" + #set tok "" + #return 1 + } + } + } + _start_dquote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open string + error "tomlish eof reached without closing double quote for string. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "string" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + + proc _show_tablenames {tablenames_info} { + append msg \n "tablenames_info:" \n + dict for {tkey tinfo} $tablenames_info { + append msg " " "table: $tkey" \n + dict for {field finfo} $tinfo { + append msg " " "$field $finfo" \n + } + } + return $msg + } +} +tcl::namespace::eval tomlish::to_dict { + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "preval" ;#5 modes: preval, quoted,litquoted, unquoted, postval + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + #todo - track\count backslashes properly + + set c [tcl::string::index $tablename $i] + if {$c eq "\""} { + if {($lastChar eq "\\")} { + #not strictly correct - we could have had an even number prior-backslash sequence + #the toml spec would have us error out immediately on bsl in bad location - but we're + #trying to parse to unvalidated tomlish + set ctest escq + } else { + set ctest dq + } + } else { + set ctest [string map [list " " sp \t tab] $c] + } + + switch -- $ctest { + . { + switch -exact -- $mode { + preval { + error "tablename_split. dot not allowed - expecting a value" + } + unquoted { + #dot marks end of segment. + if {![tomlish::utils::is_barekey $seg]} { + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + set seg "" + set mode "preval" + } + quoted { + append seg $c + } + litquoted { + append seg $c + } + postval { + #got dot in an expected location + set mode "preval" + } + } + } + dq { + #unescaped dquote + switch -- $mode { + preval { + set mode "quoted" + set seg "\"" + } + unquoted { + #invalid in barekey - but we are after structure only + append seg $c + } + quoted { + append seg $c + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" ;#make sure we only accept a dot or end-of-data now. + } + litquoted { + append seg $c + } + postval { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } + } + ' { + switch -- $mode { + preval { + append seg $c + set mode "litquoted" + } + unquoted { + #single quote inside e.g o'neill - ultimately invalid - but we pass through here. + append seg $c + } + quoted { + append seg $c + } + litquoted { + append seg $c + #no normalization to do aside from stripping squotes + if {$normalize} { + lappend segments [tcl::string::range $seg 1 end-1] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" + } + postval { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + } + } + sp - tab { + switch -- $mode { + preval - postval { + #ignore + } + unquoted { + #terminates a barekey + lappend segments $seg + set seg "" + set mode "postval" + } + default { + #append to quoted or litquoted + append seg $c + } + } + } + default { + switch -- $mode { + preval { + set mode unquoted + append seg $c + } + postval { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + default { + append seg $c + } + } + } + } + + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + switch -exact -- $mode { + preval { + error "tablename_split. Expected a value after last dot separator. tablename: '$tablename'" + } + unquoted { + if {![tomlish::utils::is_barekey $seg]} { + #e.g toml-test invalid/table/with-pound required to fail for invalid barekey + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + } + quoted { + error "tablename_split. Expected a trailing double quote. tablename: '$tablename'" + } + litquoted { + error "tablename_split. Expected a trailing single quote. tablename: '$tablename'" + } + postval { + #ok - segment already lappended + } + } + } + } + + #note - we must allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + + return $segments + } + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + proc get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish::to_dict::get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "tomlish::to_dict::get_dottedkey_info DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + +} + + +tcl::namespace::eval tomlish::app { + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + tcl::namespace::eval argdoc { + proc test_suites {} { + if {[package provide test::tomlish] eq ""} { + return [list] + } + return [test::tomlish::SUITES] + } + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::decoder + @cmd -name tomlish::app::decoder -help\ + "Read toml on stdin until EOF + on error - returns non-zero exit code and writes error to + the errorchannel. + on success - returns zero exit code and writes JSON encoding + of the data to the outputchannel. + This decoder is intended to be compatble with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help\ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc decoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::decoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::decoder] + } + + #fconfigure stdin -encoding utf-8 + fconfigure $ch_input -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts $ch_error "decoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $j + exit 0 + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::encoder + @cmd -name tomlish::app::encoder -help\ + "Read JSON on input until EOF + return non-zero exitcode if JSON data cannot be converted to + a valid TOML representation. + return zero exitcode and TOML data on output if JSON data can + be converted. + This encoder is intended to be compatible with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help \ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc encoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::encoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::encoder] + } + #review + fconfigure $ch_input -translation binary + if {[catch { + set json [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts $ch_error "encoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $toml + exit 0 + } + + punk::args::define { + @dynamic + @id -id ::tomlish::app::test + @cmd -name tomlish::app::test + @leaders + @opts -any 1 + -help -type none -help\ + "Display this usage message + or further info if more args." + -suite -default tests -choices {${[::tomlish::app::argdoc::test_suites]}} + @values -min 0 -max -1 + } + proc test {args} { + package require test::tomlish + set argd [punk::args::parse $args withid ::tomlish::app::test] + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + set solos [dict get $argd solos] + set opt_suite [dict get $opts -suite] + if {[dict exists $received -help] && ![dict exists $received -suite]} { + return [punk::args::usage -scheme info ::tomlish::app::test] + } + + test::tomlish::SUITE $opt_suite + #if {[catch {test::tomlish::SUITE $opt_suite} errM]} { + # puts stderr "Unknown test suite '$opt_suite'. Available suites: [test::tomlish::SUITES]" + # exit 1 + #} + set run_opts [dict remove $opts -suite] + set run_opts [dict remove $run_opts {*}$solos] + set result [test::tomlish::RUN {*}$run_opts {*}$solos {*}$values] + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {[info exists ::argc] && $::argc > 0} { + #puts stderr "argc: $::argc args: $::argv" + set arglist $::argv + # -------------- + #make sure any dependant packages that are sourced don't get any commandline args + set ::argv {} + set ::argc 0 + # -------------- + package require punk::args + punk::args::define { + @dynamic + @id -id tomlish::cmdline + @cmd -name tomlish -help\ + "toml encoder/decoder written in Tcl" + @opts -any 1 + -help -type none -help\ + "Display this usage message or more specific + help if further arguments provided." + -app -choices {${[tomlish::appnames]}} + } + try { + set argd [punk::args::parse $arglist withid tomlish::cmdline] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + puts stderr $msg + exit 1 + } + + + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received -help] && ![dict exists $received -app]} { + #only emit cmdline help if -app not supplied as well - otherwise app function can act on -help for more specific help + #puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + puts stdout [punk::args::usage -scheme info tomlish::cmdline] + exit 0 + } + if {![dict exists $received -app]} { + puts stderr [punk::args::usage -scheme error tomlish::cmdline] + exit 1 + } + + set app [dict get $opts -app] + set appnames [tomlish::appnames] + set app_opts [dict remove $opts -app {*}$solos] + try { + set result [tomlish::app::$app {*}$app_opts {*}$solos {*}$values] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + #The validation error should fully describe the issue + #no need for errortrace - keep the output cleaner + puts stderr $msg + exit 1 + } trap {} {msg erroropts} { + #unexpected error - uncaught throw will produce error trace + #todo - a support msg? Otherwise we may as well just leave off this trap. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + if {"-help" in $solos} { + puts stderr $result + exit 1 + } else { + if {$result ne ""} { + puts stdout $result + exit 0 + } + } + + #set opts [dict create] + #set opts [dict merge $opts $::argv] + + #set opts_understood [list -app ] + #if {"-app" in [dict keys $opts]} { + # #Don't vet the remaining opts - as they are interpreted by each app + #} else { + # foreach key [dict keys $opts] { + # if {$key ni $opts_understood} { + # puts stderr "Option '$key' not understood" + # exit 1 + # } + # } + #} + #if {[dict exists $opts -app]} { + # set app [dict get $opts -app] + # set appnames [tomlish::appnames] + # if {$app ni $appnames} { + # puts stderr "app '[dict get $opts -app]' not found. Available apps: $appnames" + # exit 1 + # } + # tomlish::app::$app {*}$opts + #} +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.5 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vendormodules/packageTest-0.1.2.tm b/src/vendormodules/packageTest-0.1.2.tm new file mode 100644 index 0000000000000000000000000000000000000000..e69038aff2079adfcfb92e7cb382dbe03c205aac GIT binary patch literal 11871 zcmch6c|4Tg+rPC?C|R-EkG95*|Up`k`@wkS`wIM-1`2jUA}B~tD41$YJb~nmz+r>XkP{YP3rcVJOqU=$kI&l`(J!_s`gGa`cGsQ^h631l)BUPDG; z(7-xi6%hh%qmZyj3NRg6Peydfp`lBD!AgkF;e*gVkf^o zB?52=U`Y==F9}K0 z?oay^7YhM#zXU-jgvOE4D}$5A=gG7(pbG2t*PVBn~cc ziFi0z!8;@^#>i+S1q#-O3|5M1cq!E$I2;=90V<5Rz6+$I11W*UBs9gBgolDdmpU8X z0)LinGx%R`(}kQC9sVbf@QHBTz-3Ncf0?@QYxn~%(TBth{<^>b5(i>dT(YvN^9Kj7 z{2D_bp%I|A1OQ}EFuYh=JV54;hFi4UV1*cFi@0BwP0 zr+^i8gqN+X$jVRW;$TIaE#CpFk3%BJXg69Vb|a%bywP}2oSfiFhxY&_5=Zb~Nc&$Y z3{uI(Wf|gM@@Ul*E~aEyh2`=nNSu}y#T)J$WXcMn<_(WSx_QH5AaNSd#e$cYefTIC z1a-?IZKxGw4*k5u zf%gDyZ!vmW>2_I^hrgWxfrxT}wu||Kq6HTnGzky`*vBXc7Qf7Au+s3y9puHq72ht8 zo8?cIm`!|%9)C;&*ijf?9Bz)4Ku%r+Ktr661UzW}&{84Pz5)6(EZGIp(tjE+oO*8?<>cM9oc@ zr2!&JJm`@@-;kX6yMu6Nw7X)kxD=CMN{xNv9$nF4vh z4A>i{MBp2R#vua95Fq0ISUig0Plkv%1O-$+z`Ox_#S`%I)OLaZD#)yi%+?bo?_eWn zlD^)6)dqrY0))`4uc!zd0Ar&OSkN56bC4kj;7^J_fpm~ccbBq7*!1vcAv36U0UZGa zm@jk?4FEeW50F0>Q&B}lS}4IRi^pmc%X`q6A+GL?H!I z4M$noIxsS7=FHtxR`d?M2>ysIv)2Myh8C>zw>$>L4!+ExyZTX0wCe*^)8 zp<0bh0j2QQ6_gCFpSrrbi$Zsg>aAk)JzAw>(gg{aGA{cs* zKwe`(^#kP}gdMHuW3T}r0I5jeME?6h%jv~Dgg?Kb`E+rFFL&dLm&V^OfB(_LOH4rH z0MNX5sqTQQ{r~dtImZLf(M&~^2U?%gqMt5*H{OzB{rGh}Xj@@r0l0S$^8 zCi8b~csv9+7Dy555Qf^YX!HdVUqtHujCEyKhOS%%#6T^gnR*G`g2=w^;3fht%>I-aP-o)0x!a?cttzS z4Hf>EUS1~huPjjvgTUe30lkG23NHR2;pREiGD&cvh*=mYK=y!MP+1ES@OscaVN+09 zfHxWik0BsnH!>s-=8vG)fp@ex0ZayPYM2?2S9ZkmG=n1m9;_@B%fBWNynnv({>IN2 zl=?5rJ(Zx4Js{CvQ3{V+7sM=317J3qcJuKGzURXj^h@A#T6V!i0pSNKFLgLbo6r6> z<(scV^WSq9cy9m$QW-UVhH%)S)9Bl{C|X*rd*kQILBe z;E8x&;QP6`E|FSafvc!RZXxmDiw+LVoD}|?YB1X0klF${)M+soDMNr80TKaw9-KCp z9^j${QwAU%F+UWBN%pTO<#cz`vrR6T;&$W(CY3I#D4`0 z%lZFMzu{w6uHk=vv-0}iCbYm&v}?kDW!7b;SbE0NU-19XECf6VP*6;NjTQy0%ov%t z>FDTK=!|8f9R>SJel~BQqcgUoqf-D+=ljoG)v^V*K6xbtWd#+*WlunFysLeX{CaCa z_tX}vWBij^sX`euT@SJ`O+hE`jJ8X@j&ADYR53O@alA}@S3VQg>BZZUNzK&|Ya%4^ zAS)vd&9!aYBp+SedGbVVN5Z=q&l=qT#Kn(oF`;!i$P*rs$x)`-==C!bn$@irzeoNf znUIih(s+=Smu>JF{T3zblvr zEk-oo%U6SohTa~ z8X6kAz*Xj{{W`#h?cZ8HlRFlJAt#x3l?}01NsKGhd^}0H5Si^;Cx=RjtpA{t5KtOf z@3+}g<>A+Xph=ZgX&QpUL%5-BV`=x^m=hZVWvnJg17legXZ?{m5X*Cw|BkaJLnCc@clGv@4>wX-s=4b`w(U^ z#HhbZjEhCJC^@mei!yM&T=(9sfzcP4vSq3vF9KBHOUaC3sTh{M{P9dy0lcCKsDE}twmX}!Yr zfdhJC8RhcXytS$GIh!pX+p*ns$49p4uMXia7pb$Odn)m|_DR6`1I|ogY;{OGzs!BzfP-LK-pdS!TCIay zUkbQd-;9ZQFg9Lquc6U{V+}Z)IHAVw5{HxzdGGP`qc4Ls9b*lLc@L@k*?XnSBFNo&tiTvWAX{0;V4sIi-^VcE~ik)$G+x_{hyR-q;8zH7UeYAIr8 zQ(OD#vPb%+(1&aLV`@i_gnh-pN9x0K30#s}OXD(6E={9QINSf>q9j<1t(n97YE z+QqB7<-zU#r^QcnED!yw=^(tbB1hGFM<%yN=`j{FVOghU4{kf9mQKHk$doPqTS9uZ z3a%%M_tYO0zP&B_k|H9BG*EcGW0mHnf6X%e8sbp`G7f#Iha|amoZ}K3^2863jvx?6 zG`YTWAT_O?Z(>VTLRK;siB>gNSDI+0tE8Q?FwJ*nWe@v@h4JfnDZ$E6=N&?xHOYo^ zN<;0XzL8Rs)!>c5Q(f_&u67ibo9piA5_jlMm92=a&#o$1x7)3vGGcXHmd8M_RdKNR zrRxsU0s+&5xaN&)B)V&u1N>IAB8quxW$8-wXLmDRWRP$sR&5hJnRN(SjQyf>i7?_$}35|}Ehq+RWU4+%&8VIO2xkQx* zv-00Le##rE=9g-*)6Ko1FahQtl$PxPq~fzFPI^nEP_? zRk4yKJ2<}l=v*`1*D_T<*{z)0RN#{m81AiuLT$buG^k_Zsi7Cjz%J#+lJag}bXg29 zi-?<lvq&VJ_a>n|aseuFN-E=}r%J zynV@(ntYq5=q~nBqey0+3tjqYVb+v8Ba$gOZ$2@O#Ctz!+>^~IqgH-oeW7oUfXxHw z10+Mj49m1fWrsP3ePfO7AJ@zIC#YVxq~wdasgQJ<%ZI(l%I23}3=>7yw-oM(%(~oZ zkS`_ckfZSVdOUquz!~***%zATbZ;j6y1jnm~nA;306T!mzHEmea z$Rl)KNuB5IeKlTDeC-E(#JQ0;XIsNVHRHp6kB=Hr7!=kzi){TO#Xbq?1z zaFFA0I{a#yOWzv)7`+zbvpD+$>3-@RXoAD{`+2rfH`eCH zS^ta}ubUC@WRJnDi*k4NM5M{cD!vZLIyAGkOEm-_~%WQN%ZtC_*T*~dRj zq1`br*aYVYqwA#%^EWS=ln4}PH0kg-4MV%3e;ub)>x8y_DZ`!GHIkl@zYg=hJ3 z^U)4<43b|zp2vJ&vco;qb)OhQHt{Omn{a!R!6Y438t&98U~r3}We4Yv_KhiL;*CXH8Xoj*m~@_251mt2Vn3Z!cw( zqTxq1q_Dsq9{b=Mohq`75=I9Mh0{;=`N?!&xR~9Z^|mqhba1EoEMaGR?X6a;tlUlu z_1jRNYUPg|yIt(BJ`za0SN_naRCOuSM2Rw_UU=bZ<3{mG>d;s}~FJKBsi) zA?EqDLZWI%f%=ylDmQsY`%}kS2Ka}1XX~sgaQ9a$Y}P=Ev~I~#dR=<|pySIj_kxbf zP#v5$`mJ3>llVv3*%t^^t6K8w2Ir2M3W1$*UZhhO;}AU;5oLhIgJt%#j%1~7LY?P1U$5z|#8^iez zvNHu={nyP5zI( z?C3j9!}YBi$q&T@x2wG}u{nIt>r+>XWtybygjFtcLSjIq(RrzI)@{unKfZHSH;kq~ zsW4D$L}@v0hjI2z9yqV~+)XN#vwBjxqi-Kex>V9WL5*Wrjm|SA_ z@!k0-beJ`-vYn0>!Itg((gehGls5GKZqwFKgIU{?CpEXp#It|m8({f}6Sw_Dk=hq^ zzdy42k)T+srSE{T5v7?o3#pS@6yMGFA?;X~nV-T;L;tP!Uzo0bVsRa7lG-^}#VnHx zr;!;=u`%KdeUW#gq^f#$Z1gZqtkyfoo)~UQI6`0fNceH|h6>@dcWWk1Uu*S{8*DDy zoZFVm# z+r2fcPqKU4a!0a?XM~GAznph8c*?ae#4dMS;$fU6D&L}*iOev(Pg>{IC6U{_*1epw zs#=b9H#S!`9T_RBw$)sJkT@b4yZH&-rS)Ovw_n*+l_l?ZSnoDIJ024I$dq9}k(&)~ z*-*gd_tVpoH$uqp@r@RvvWdhkKIZ~+)CG<_#_&8$={l=vdq$hZMX$=)%q$tY(l~PL zWtTcmwzOK(``NaK-_!&s2I<8J&nDh`9GaKHqAC-PS^XxpCOxCB(NoAuXr(bIY_>BVVzZn*?W`$V|Y2 zDIUQ%F}^yq2G*8W_I3}~&_|4nO1LiTMGK!n&3boPM;S}&sQS!+r;W{WtF`P6ztCSc zI@SA}*4(AM2%3B9Cx)5#k(9r zUfa^WMm3WfY}(^$#sx0f_q5({b?c7*$`QtNQsYwN0j-9nB(3pXV`6Q0H}gMh^UCfH z_t_f7RrLu13I-b(~`-T&fQf zos^WdhYW07Z9SwQn;I^ba{+spOceGO83euQlhOZjUVH68vRZ3J21zEB+r@Re{@q81 zeV^tVP8&E1>q?tu?v_&)kp9PUu(_KhWbcItwxX7@B4oQs>F8l#3|(|-#gY7utoA0C zF3A+j9CGY1OCODhd!k1`eu zk&c|Re`6d@F12YqbV*T^aMMv;pDTIbI-9&QgUGG2$U=Jtmi`~fwLZ|XL3JLf-S4f) zp5xJM_q90NOL!Ve%QkuGX_Q|7+I!*rtM8KsJH|Rgf5wk$6mXEGeT9v+^)@tLuRAG3 z?8;~M9Njd`D8ayz`y}URcF4_=txcTozRiv_Js(Zb+p|xs$eq}(tnfh~!1Q`Dw{^H| zZqLZk8&fFeTR6oev(baHCM8w}48ms27|5LJF7Y3>7k8eGm_Gkx&(;QxX^)EA)~Yp3 zI}e^@H{jp0P6VTS!dOPnEw8fw%B!mT>sVchjIxsDO6~2BEc5q7w<+s9sv52|%?Tzl z3*4Iaa5Nqsc^36}ZDH>!&w;Lla8t?Y)pu@|b5=ZE{Z4wu`RQqsl-IhQ_gT**p+4Bf z6|r6AVHgpu+I-r1 zOaH`|S6j2<+p8bhNT$7r*m{|}1K-BjD#ds|@vOpAxJ7Kby-e>6f zXmYoup!S2@v)|eCl%`d69>m44Uv9Yi=v8iljsBjz^t(O68n${zTlAy0?(CkmO#bnO z)#=QR1SSt1{+Hh7vO$8`hRJujgV`;bZgx3HIlZU9S^MBDbHJv_jn7&>jP>oi=lmw? zl@sD~qs}YqI1A*g$8PQZPQ40#58Y|m7Ytjc+zuViVEeaPXzE*gcSgOgd2;8*_{NsA zqb*aBcIYE(ezF)vV!dunZ!+31p`N?yu5V>uV%^5?8-%~vAF7(43&QvHajG!`8P`X0v(2Z1)Q7!bW_*+DtZe zA0H32V(g8)toPPkCzP|wzR2a4>RJubr;_2K!O8ntZvS}12q{d~x0+v9Y_MS+d%?E~ z9oVkCOIWzjRPmNk${9Y*P{hk7g+|6RO){O=6d#A29{t2)acRxeKw9V&n$FE-DE+dw z_4}|PKDX135gIM2IpNYF4%q`57fu@lUnw+&Bx5`_+ zX7xJP*T#SAiY?s2{*TR1$&7Nd;*;6k*fatcQmp6jv8~^`_ehrHzb&ycqi5iz`}2el c3<(!~{%7+-D>LR*@Me1O&l!9}@G*4%4}v98Q~&?~ literal 0 HcmV?d00001 diff --git a/src/vendormodules/packageTest-0.1.3.tm b/src/vendormodules/packageTest-0.1.3.tm new file mode 100644 index 0000000000000000000000000000000000000000..676e404848fcec09010b01b2681194b06790d9bf GIT binary patch literal 11953 zcmch6c|4SD+rK4QQq~CJvXp&~n5F22V90)u zy*C!Z;*mZmB19mf2q>Hn%10U6g9@Txh$s?-0&Bo4FA4@r#^4~Z7fn)x@I)vWO+p}G zQDi(6h^OGlP>3Ha6g(mT2^@<~grtnHWE2sHBx8b6*f5BKgZGi}5ZMn&hESnoBGQ|T z@`0oR@je8+j}igt9f0&jDFvg5Bn%!0q48K49)<(~1SDi2YW@k51SyjPY0CU^pf3uC zA|hd-6cPsKivSQ|(Fg<<y6uka-j zU<09uL|{tEIT$pnkSSjD$I6fc4(SCf3JmOn0`?2U;83tM3V239lKqq+SpuF!!oX`t zNHhvq2dpAMz-?qA#+wXGM>3F;TyiLN$uC$5={bB5DhQI4gd!p!2^X3|s89@vOoHa$ z|KH=6gqDC=3Jtge*3}0?gy?X_}tBnJC) zzuOW4SR}BdFAj1c5wI9CZPkJ>CAT@V(*(>#<&xdBX!zA?0I|w^NW-Y-<*jH*5}rcz zrfc`ReJYEEfVf|RfC{0oB-9EaCbcYfV2hAIj)ADbLm?>08;Jw@!5NGs5QumJ5d#tj z8@5C|9IW7-H$BEkC~q72G<#sND4Z{-Fw#bDke(i-3KkPlWC{@ng;SS0 z8{PtcmTuerzuu+~xhy*TcOc;t;kbdzoV3w0b>Y|W2VPx1hpj;AcMl;#j?_&a=$g)qUGCHhyl7HbM~cGr@7>Yg{~Nm^E=>gEC>tG z7U*^gT~SAP*~*Hn{B$l3R6@gWOo z|1*U_D!I8WL;O=7y_&+slmx4=TprmQi$IVA;l4p4uOMpP@K|q;Kv)bUO$WMI@ba<` z9|eP;ZCRuZt%A&KLrhtY63O_9==Z^o?PSQ(Ha-(I|&m8&X?SD!bxC|~r zjU^&+zM$;u8#m-!4<8vb~Jya-tF z?ee%;{$z>Sq?hRN+cbb3g{EM!bF2h%@y7!i;^K|Rf%XqA6+-J9pg+Ts-5>-4))3wc z(Yg>G4f-~X+CYH00L^`1LNot}NT*yY>P8C|xI}w^Bj?()c%I)P z5SFywh$4G00|jdc@ zh0N`wH))!%m4*1=aWZ5$t{|C3Tto&Ca}*9D16Bx^%AbfxfIyP)fKtt4hd^*)QAiRQ z@`V|2AWVtCw+{-73?o5+h=*WsKKKw4M8G1+pz;Cc4cIFVk5i(x6C_YUZe?WlelU3l z8$pw#1OiqY2D%9lLbtw(3UC07jZR=ea{$jlh9H4I$su@R0FCZ0Ws9)s;m<;5(Ch*_ zf)8N6Pyh-5c3B=Ezb~eeDk}6)f>{b&QkWrA4joDme zEegZYnE!2VMk!q?Xxhfh6t5V+9-wvG8C8rX3X^LNbU&=y>>pxlDHsQ(cJ z42EVk5*d`jpI1;4xPI#E>n{r3x!MZp!fpYV;h*`S51~Pu19yE_oEHeiIh7DA?OnWS zP7sOW?Ttc#VS_8EO)$$^T*-gN+s|}_7SvmMrJc9y;_oG@8N-zwF8CCJFA?cOa+iVX!vN3;T-KW50>_~hrD1PvM# zEllR`+VFS?a4e7_v>^1k_!6+OCECU7g=bQ|%A2@pHTY(qhR=lE} z=7tLYOD``I`A3#0g+^krUVz@h2?ZB_kZ|)HYMCTBQKYQ4D?^TeUeH*JH{kW4d%~um zv4B974?Ko|fZa%t5|}@NUI*UM;{-4nz^P$oKw8-m%hL>w0C=#nP%QtLK=A(g%KHmH zUr_45EcY~mLh^+qe?}=hZe0+wKn;M|=-SQ4C-|NZW6&>w&*|9(69r^2sJyh{Abmdj z%am`v4$XhhUEl)&43M*uW@tdH=yP4V$i?GaBoPGTf_SAltJ8*#a8%Mw4`P!xGxmYJ z!T?XiQGoB~=DGx0eFd(f6}g4PgD*N*FmqD=eX7A|e?e*w{qkf0@t%N71hd|CL#nnPTY~OMk)tL$eU@AV5Je{W)3`wy|Jd z#m~UNz{VhS?1;0`)>Guo;HQ=?1A{VnI^Tchs+K*t^(m<;t0`-!EPDcaW4&%b>e-!F zo=+xtO*_>Q^HfP~rZf@Zrx6SA7-pe`M@efLE=AE_zPW!6} z70t!PRmD2AMu2@tMnZwbSEgt4eov7fC$leZ@s;FyFww+0ASkC$)vluL^7_r8`Ukit z_zaZLodMA{mJ4bMVhPRsgikD8OrAz(4$HpMF-$(LIoV@S-Y?O~bt*euR?PdspzI6w zMAw^-DGwO0$a?l}o;>O&bjSAn-M4vzhc15Sl%0Uqr<{9nR_MY9t+m&fGG9mBnaqga zVs5lvaf0v4tHh><25HE|NZrN z#7CtT9#-E<4~7nrL*mDbDD{IPRQFRy?uK%gNs8TgxOac{!PMqT?Rbn$K1Q*7?Tit5 zmz9B@9_qP0wE5BJMr(BlTWNBRqAqxLi=y`pKU-zYjHmlCbV}Ie8*-=PI4@5)^Q>3n zy2jT1k=YV0__ym@-A2zT^zGD`K+$;W)Yc4kD})NmXx^(w>;0v=cSvlwbvG|@r}l$& zNM(btkla%_r%{l(&gWMJmu6D z?1b;o@QtPnsn=b@5qDxDV*~qle7g~yS)#x@BdnKUr(BA`+f9f&NjS@j7IWG)>YHgn ztasj>FS@DxN=P+Z#^@hS&h=_cqE2^DrihLXvUOU?d#w_a{&LG0ua0ST<=~ucifsEn zI)%%zBe)Uxm_s5aD8@A(s-b84@9g4=Lb2|aeS61JorCdR+KGKTbQ^KZ$^?;vYX3^E zai@M}!IKF-)O}mh8pv-Xlw%2X73XhyzV3gBQ?zv3dYCG)k7=C|!{9el?rGh|ci;9s zDd6}Z0NpBVQm#86F!s@VZ3!34j!nL%n@;8!-$*#l=Bp6(Fd=Z*_L8|8BF2$LP#v$z zX?~b$HgHY3@p}Zz6MMFk#%;tS07A>VKw^cX(Fz2}pfA1|_tNAOP z@b|l%Un-PPg49y#XFm^)a=0opzO(DdKA&3}bRkydfL7gAGYJ9D(>*cl8SlPmziqNp z7XB2Zc*nmANOO;zE2$pgo;d=JUIwkm2qavtf#9)0hYk#ZH!na85lV|Mi^W7TC> zZf|VVOv-QpR%Dp##>Ejw);=u6z?LH4;M%5?Q&85~;e8v(DnyoP`*E1V=IlaBfGmBcpZ6an!RzY0;Gq>8tkGs@8XzWhc74F+rxj#x(dp z`72W+!8Rf2k;Fkw?+j*+3m-##2to(UG+s>36z}dfRNj<*AN~BDu64X&=SaF}{tk}4 z8j8a^(q&rB@k(Jqg#?ujRn$5GcC|}mCTZOAci1mVHr|R)5S$i`TVGrIRQVel`E_uT zqi)k)hqP7SJ|B`%G~*k#NJF_^D@WWmvWkDm;V*VsDt$LcS8Y)a`wlM0JZZ9GVoniq zUl#JbNo1bMy3U|@qHK%Pey*Cs>J*aJUslB}vaYA3@11C$m^9|^@L>HOBRm?-rC{Ek zf%dzYTe(g>CjF55@S&!jX%p-FWfrZ&#;+_B9K=duTEBj)4LzE}aHw@-X#1J{d!DgA zzHZ!6d=ga=?TfeCT$T&5dit+B$+#Z+z`Mr8m7|JUyrn_T=GLadx++Z}|A1_zhu612 zEeB7B^Ra9tROP9b_1K(@Rf)nJH@V=EbH!20tX!ib!C}>{?CFa*_QXK*4cF3e%F_F7 zzxHcaoXDzkf)sTMSw@KtK>}SLQR}A}wmgqIQ^{v;CM{x>cH(lOjGU_g$~Ec)_n1$~ ztsKtU9Rga353iYWth?=!)0>Fp!)mth+YQK{u3|j+cbvg@=C4<7B-t~)-x>F12WE$4 z8H5+gd@6izLw4C4{gIJ8VK0iKlkAYN<5zJC*SUV)Rh@45E~j^~ygAnOVwxkng*6|! z#W#kt3tc{zW)(Ff{k7=vk7Q>h9RrN2V~xO;Sn|06#n6tOSFMgUV$yvNFeZ%irwD2D zPCVGCdzAS>!>+%w&;BcrD666)doUx>pQkX#$28rixHDk=K7@U=+$SdigG)zK98Yy? z4qj?+D@gywr1R=)h)Q>g;3xUW-)8b(@`H-;xm_5p~OD zJ+BG^I#{QaZZn2kU7Or1S~j{(f3wzx>f7s9{SC40xcrx!j@zd#N>VvUrMhkMaE;lk)WlG{bZ`aYRS zYxx}4xc`srN%=M5a!TW`O@{pQjW@I_wADY((+Nrz+%RA)D^vZ6(Vwj=(5^V~FJD#v zP$k0?IyL*Xko^4EwIPAdg+w-gthgbnfR(A}Lhafjy!P#=FWyftk{=0g=SZqV9dzfr zdfs07u;lK0F;4r@k_!7;aWuQXs_k8cz8x=Xi=Sg%=f1&SM5O5+>2o^; zi&P(1xtM-5S$pphi^mhSs10qC0$!H+6&L+HyAFR=D|0 z5l=grPAPZ1$&HU$7|qZ`SMIB=TT!i|e_Oip3^9hK-{r5NK5rutgb#;lL-}v9YLKK9aN59&2w8IN>28qMUBeo51FbLK4w3+?iIF@yTi1VS0JZ;E7pB`Belu< zu#k&VaXYu6WmWj(=-ZvA%D;2;P)9`b6Ad@zEBz~tZ#+@9xrfO0}?N=A#*S686VFj=U5Bgvrkh%D+&^fc$@mRivqq`qCFRdFgxH++4Wg<+$uaqlGWfr_DSC2l1W z<7#$frSvH0Xs-n)`}&Va;T-LUIl8OJQlS&lIod%CBOCd*I>nyoohGEzBk#ZN+Eaf~ z{g&3wS=K9h&oDWfioHe~6M}N%lCBhei+JhF(XVm!>jkycTs9wz!+}_4j`63|XJ?0> zt+~#e+u5i6Z0*ITT^|l9t8nESwq*&73<}=kXQ~>vxmR)iEqU7`HRf}iHcZDoxL8dR zq!TvIPRX~}jm@!t`NA}PItjH($3fMB>gCpE)NV0B+1KD29vN@VVzVxq@ky5EA@{WurFPO&aF^-7+KANxY0vdu4mLW3G?wOE%>2~b z<#pG+aR}3>t93@c{O!K$-uA1_6B`F0BEpc>wm2vc4xUodlfd18pzQj1!igUNH%#UthoHUO1 z5M^ejufDg>b&;@6Z7m(&{Pn(}W?P^!DQGJcz^z%*Y(&&L6pfef82ffJrC#E=3!9kX zF-2BVC-m1HTch@L3VQ9qe8iDlGco2!lD-=i`vyuAk**h)m`*J-k#0r~*lP;Mi@ezu|`5$KbAL3<3 zQ(K-UjnqmcotCZ0$TytW;NQup%pySLK5bGO=D}=#AQ$I*FVDw{kh+txy{h0FV~Fu9 z!CH$S=kNV6#B@78DXvNg-RKo7Jziy4?GXM%4Z-s~bFC*2>S9Y+Z0AREO@J2oK0 z2X`Fx*mG(lPalD(XmewHz_H1Tiw(;gZLW4UqpMFg^Y!$(Hj`{Ljk@-I zd9-aq;pQX(5ryNQ>x9Q@byznsIj#;!u};f9uKM87)ICxpBS~s=t)81Hk>Of1^%TaCwtEwMT=a^yonridgU9Be% z_?_m^tM0cEY&_&-a%$^&$Nm1#x|1_Np}<%Kmj=|~leZ{^+sB8nerP#%&?uro&ojQK zMdOSUbnjoIRV9jbL#;fwN@FLkjuxk~G4Fr)UL)yXLCzaWwxT8O2{oT9v z>1Tdw>Z(hxWcm9pm~NQ|=>Q zY&Ru1zh&h)vDfkPx^kr5wsZbYPZFz2@u{{l_B|qpv;u5AF&D9)_)(+z3?$QI&b<;p?WbF<$^q4$Eb)??}p*;96a`qFO6Q< z`nK?R$mBc7&|fG=$k2(gec0GtxKI6>Q>lcP@_yFQ@(K^+Uy`Hl5saD>`1UKpz>qH`Dn}c5Ly%59hRZ4t=5!`*<$r9xy@uNO&z3HMWgY zmr<;Y??k$MkWKT@<0f=bjC~DJjL`1k&@NONGq7gXFXiM^i}U4>H%_0S4m@vUqn|iK}Mtb_FcY|6wmR{oFnJ!iny8$c{2)+t$8tNXh=*S;JfY1 zD8_o?dGixne@jwQM9E3smhM-RJN%q$F5>K~w|kh1M+wUFj*i;y-Z@&EY{nH5k=<#O z+e^{Yz+2Y%A00Y)f1h~l@o*nwhi1+3H!66(c9~NIJ4wDB2ixpA-FQE{UfnG!JsP;~ zL;hVOiLM4g+j#NAyWi&-75rE=u=r>13nh*T`nE0=4RZUNp9(##Uq5C;_S{Z z&yQM*s~CKLRU(>l=H}xrL#Hhb3VUKNCmP#FZ*ug_Et63Q4Ge$3-Pyy%=ujLJ-yxB3 z-qSS|+2mu-g|LcA)6Ls*7ucBwfUd# zQOSK%Vqu|NVy}|}uJW=^?Q=B1#T1;s77<~tKUr`>dh|%1ftF?Z2BBmLOlj5WW6#vC z=lZub{u|Tr*L&_9&nHLj-9;AkRs=LOg-pGEB#9F9`#OL?tHdYsS#AzTr0pR*4dUwC zC}(+(sob;wjoQ7i+sY?Dg);CrhFXbauOb|%`}Vp1>0onuz3|)V9cIVIngjRXCS;YX zIh&{%9R3MPnJgh!N#Bhw%pfkSed&+tuJ2K{<*d6klWr4NMX3Vb74m@udIuMe|6Hm+*u zpuDMOUw^vdL;peH!v3>-B^KAelyP~u4HsnT+P;q*4u2qD*5Jr%=*DOp`uE;@f;|q~ z!_U>4L83{e7ggmp?){`!5Zm@vPG#m+yqeHi@@)3o!$Yh$pn^B%vClg_`X1L7hY+XZ z1>f8W!ZJnJJVbwTAb)sf|AW=Wf{}@z;rBB~Fm_z@`JYW7Z7f(;!pm1I>K zD1=I7R8+tFIR_E-9k1`}clzTv&vW0`{l515zG8zGd?XK`36KXGgM$3gWG~1DiGeV9 zggc4|5r`-P3g?b;SAzDSd?{!miUgs+8t}@Eg2s^1I0)?ZASpn2BIM^m($$4Uk?{}~ zPr;EPe=k@lctija*cO}!Ng83uC?XC)M*E>Kfe-};?<3(MvKN93p#sQ61d@z$ha|Ch zcLLsBk$^z@AUsiuekdXdjmJSAcnk~=O@aUd5(0~wdx9WAN@OfmncoidMBz|G1T2(7 zLgPGj0Yq4|t}X`crmKrZ_@G<>1{c~>ND=ShK|+zqfdmwUAR@g0Oh^yBhpl7)>5;M2 zKNhKk_JD#MkO(r;3ksqd6Ne{a5g7CV6y$)$dEg-ul87ddokHM~;RWEYphXg31EGjS zU`mNu7*wl}DQ>jKO3+>$!VOpy7}y;J?1x3;P_Q%#ct${wy_6ss0-i)d!)r(g4-~Kt zSVe$<+sH&Tk_=2o+AJ%v=+KZwzhEV#X7NENUr0g%3J!+E9jFSS0?;Hf37UKVzsD~D zEdsL`8gK`!t2>$q(cpl;aIov=@hsXryW9nVb9Vt@GrNa~$CIg>Xd=i6H0IZSr$quV z2w+K19OOVEV9;dhs(E3GPP1mG3Yd+`MZ2ld@VnIjV&%DzhEdPSTh@{!JcWp)Y4@jn z$_s^nxL<@I1VUj*sAWP-a!KsK79oKg15tyA{811Rfdl%%8H^whhgav2|G&=<> zt0TN@c}13gIvWSe+HC0#SbYo@glt>KTe?IMhr7%b( zC#NNdf61d&Q@EItU=^0iBO@`ox@0WeH%R1VM9moG#pU)sYy9|{O@*>T6~fdHM4%@$Zv1|Rl>k!Z~>FUB7!h0cV7s7jh zzD=bz5MVAqb9b1~%snE~DA%&OQG*38(JtV~*`A_IGdLAZkX*=OAWm@S0qarjiog{x zsan`PmYng&?g5+pcLTtZW_4U5Xl_0A@P%OiGdOHZ1XDdnEnP@F77N-u38LmE%+df6 zrJm;m0fHnU@u%>WL=ZhGaNPj(73PyjFF0;Nyx}1?&;WV5Gb)m&VW_Qw> zG*#I0Lfr8l>r4uG-I2rOt0;5o<;1n?)>A5Zk5(%r>u5jH*ina>QWT|h^02h11p zK>@%HO9SN3#Z*FBnHEYg%c3Qk1cXDw2@QVHg#Rh9U>tyEkqBrq3No@Zn~kgm0Xm=L zv!;gp;Q|1z2}CjlT#MjK5e^SrM{uXwL~)jx(H!c7!~274$)ebWLljRTLu6tg)o|qH ztpg*YX3p$QWm)gQi{Ovs5_`>)WoX_yf6HS~?BL5B3JdE)0v#DXn>_1!1msV|10Q=* zP$Uv0gCLU89^l#sfue|jyC|HP;Kl+xzaVx&%#bK3X!G)6MS~516DWWSNc;u^SkcJLXbo^DdcJZr)uX{}KcYhH5nu z8I;0bS5OkTei|4UEC}7%+6w8xZUL9!U-@7Fd4M(t?)r{6HxP=mD(Nn_cj2a4K_m(i zi9&&4gCnR-Fw0t4$$!P$uXKdw)mwa}owMu0??tK^!<8K__!NRC5#dhdi(u$M1bK}H z)en?^5O%bp?|}{g0Z2sxC-UD9T1qeGApH3a&8G_^e5o6ky)^!Q`TLh1USt9q2Y}|h zOLYfa?f=WeXB`hbM>7>w9%y|I3w}EN-FSSxh3>4H~b27kw;OM1o1zv<(@v?TB9V+~n zUS1;duPjm01A)P~0eTB36kPm4!p(80C6eGok+j&N1la<5L1isS!0SQxgiS$Z0a%nf zJcfXP-AIrkm_LGE2j0=*1TY!EsbOY7THX;$(+rLPc(5{GEdQE7@cy~V`x`%>SL)v^ z_f&#H@`NOQMJYUPofk7t4S?Bb+Reo$_?`=6&@X|{Y1su61%w}{ywu?!Z9e=)?0vz1%QgI0GJA^t01SkC`L z{f3WOzJ~w#&GPGio6rJB(XI*qmRXmWV(}S^f5HDlGav9EKtVD6HChz1+`+hlkB*Lx zg|1^m)c(e>8=qvr&y7}ebV}gqT>qJ^S~lR;r>LT&s-&U3B6VR}Z#HYq@A z$ROlJ3GTGoU^~KutN&$VV#rv|`B%p?SEM;@ICrl(>sZ@ADAlPCI`TN3Y2gqLPEO7; z<^gto)&Xg8c_vTkCmRm93ja*bysY6V!TDgUfumPIR=%uNS;yhc+lZxro{tbIJC;dmY0*ktAIL5DBKJ8P1zsNF!NiuHW+c|gp#AR*T_!`&79 zW8IHULx%)s@+uB_lsH#^WB>R%QmmWVnU3>|uKBAelVth~gQnd5BkFs868#LO*_*hT zJxg8a+Jqy-P8w0F`h-KAQ;y#Y;3|?3t$wucK<3ee#!{U~wB>oULiegEBl32O&HDPN zmp0Ib$6xDrt3jC3t>-9e0%tW8kkwvRO6Vz9=aU|Bfmf?#Plt0{9ox^nMwRmhOZOz> zE)Rj*j_>vAUB^A{CWK){B16Wt(^xHZm6?WfUO!&rE!k}%E?9dnCwiOCgVhK|EuJe! z=*oAqPj14Vb5U8{O0UFY+Ox%EYXAq`z)Xc&(+vx?Vp6l%hsSz+JLBV0G%#bH1B2BK zX_9X`2ZQUv4uxW0n9Nj%reBojnG(`ZvsSu<##@hx*^BR&5h>uXt~W5#f|%<*N`0#}#;c)Q9N9R&H@JBId^e8EvL-kY zcp3eJ$0)`XpUR=<1|O`$^8+x>yL$GGB<%OYcj`pi8bW6;z~ydl_j}%T;IHSgj3k%qT+j5nbPmDc6Kv{f8O5t_y6R_@Uao z2BpeepOH!As*9XVChI*-*C%HgS4YLOc*-As6onnMx?--X8)nNSpoUlBFh3Sz)_X&# z{zouV7k}+bch${PfSjUA<;ZdWhNR z{=};SqP9gZ+=!a8AIXnhLiCl7Ztd}L~Ya^osCPc#5+`RcrX@-UT#xKTJuVLTb#1%7N zBcv6~cn5bRq8x7&>)ti8hjNv&g_jrrPKn16%`4To~do42NUcwNpeU9A?D z8lg5A(ePwq>+btSJ6Z;fU+;?AD|#`kWqRgjz=51>yyj+7!WM~1SM#K09r;m?hm*KQ+%MKzrr#nxVCK*)Bw;wG~do|R#^SbL;!%80c!&pA$rydmby+hXJXs-qnHP0gii zg5pEkhYxKpN>0nvIDN^1{fv?BBLcr3TGCP4wEt?0`fWNBzo-U|b*urNt2658JzwSA zdwAcEeOqG6I=(Fy+scnwTdJMkdBtY9oJ~RGVh!Jn!U?e_bq$wxj0*YM4-K~MJQ%v} z)Aw5fqYWpTGhg0Dy5>3c8-AvHcJpDQ0b!!&c1mmU!EY;sEULK-dyCkP3y5%Sd6B#` zpQ6p^wEbP|z6lXAUg7Ac2<9*suA>r9?-i#h1)t&1GdQ4q9^1b;Z2cM$mdkd@8@6h? zdu6?^*-}0lpKz%5^bZGC!MZr7i6ou$@KagJ$~IOpj}2wHvsZEAW~6w8)f!Vh-1v4R zg;yo=PZA|anr-47LrH@#h99NrG_XgHi6k7w<@dq5-5;I|PT6M49%n>dm3Q`5@WrNYmXhVM%3-%TJ^VybD(GCq zo3~*lBZ7v}gMsX&8`^B`G*o>4nGs}rFlMFL_UiJb+mtB3uA;#`2OY?l3wVdQOSC0i zf*xKK(%YuQ;y7?tZ6NmLhGLe_hbwowM?I_lFt|}?)jySMYp&fAbxI;o%(T<6<5$cn zzA1)Bjv?4<`1qPHJQLXY)k1LJ^urI**j0InZlS`g?5!_^wUovCtNT^|i7raE@nXr! zeNq)j@z2>|dnkO=V0`tSZCN~R$$s(L$lGle#so1p!wZh*BV#)5GH4Jk*$@VAnsa{R z6^>9BWye7c9A2?E#0It|UKy`Bu#(rv^}IEE>RKf)?+UqsRo$smwk0!}vZ&Fx;t2=D zbSB@q`rwlr;-2V_S5|wDG#0wC%DH1F4v9JBr;N9!TP8(bwk`X4=KFp06VZD{{)6YByO9r|XxfDtCD_IexQo|g> zPj_&zu9-v#W$8T1(py263>cHj(($DmTF0kte{zhKSd}hb7mVp%-|pD6KLjRC>ynGF3EjQ-t<_N@f?RGL%a(o^VTS-sCD1R<(jO9 zAC~U+OgNDce#fGz&`79b^vwgqOb;|suB^C3>_JLbSJ&syBO@QGLnt9t;$OPHF-)9} zL9N)hS7mRAo6|$1)*WLMyBf!!Ly^0gELVrpcV%csIIp@GE;>`DYWVC(2E&aZ^L?e| zs&tY*KF)#qTEe#KrqPz2s>!Yb+fCo;=&s~Xe5v2xSHIW4{!-TE^e<04-R?Qp51{My zw9d#Czqh-Ev{`8$T~n`TuH5j>x>|jsZJG6>3kdnCo7kzB$F5v*QO@3jcvj@?VN~xK z|2-q|Wha2cx?0f{rPB+}h zH1tz=dO;XDXK% zOl`mB=XLc|?n?agp{gyJ+jiOXWV`MV&1)2jxndf_OUM`Fdz9`S!Nceg()285=%#qg zX_=C=^M+%B-tF{CO#C5Sr?*}TbYZkPn2qyn&T+ROBy6K^ExRy7?{EBC;O35>xy?Tf z(cQLP1!YkI>)eh=jg}df?+xlw)#ZMfzRHywb-5|N7dvvL|I7 zcMpN6U|BudYun()$%0`X(DvHY*0+-9?1r-&6I_xy3cCw>tP&69=BZnjGLQ9Ecm(!J zBz8C290=gj?XNmQNWWvW_kCHseUTJ?lcTle@XF*y-X}edjU-D=qfWbTk2eYCZHVC) zmXH5hDKv6(BlCI&+m$|XyA!kHRUSOPdUCUHdD3CCw+-}-O44`C_T0PBKg2F(>K62h zz17XxvbCp-jfc6cWqqri&bqvmgH4_N!(6(|Dqe_|)I?bkE{=!nA zKEi%$igvE;0q^JCv1y=Cpm+FP@~OnfYA6QTMEWy-YC3t;D7Z%7HS$T5`Wbtu`JK^< ziwczkE!?%2j*ML&E=XWuJn-nFdd$)K^%uVsx;~TlOJCRMo_>IJfTe9j@0F{6M9cnq zw95O3L)Z1o4odA7F8I8;m?+UX)V?dRXS=wrhD5SQHR;&f8C;qI6qyyjx;5S05$A z;Gom}pGTrHci%p!S2!6Onln+Cr&hp8DU{=F8y2>IDmeIqjoYT<%5b6f`@DGn&mSN| z@3mQL4ejY$2aTPDdem;%UlMmyI>0lV1PKXFMWSq=8=MyZfpNd z|K}#7jNK@iw{HRucm8Nxb2_j^wKS}Whiho}nZD1QE^i+*$Ht9@-M?b)a$!5`-joN3 z5j{oqaXw)^g(zwD#=G};1AV= zmG>@EOz_2Io~G{CpG~~>S6s%~ly7k{6+0{-$1^-^wR79>%~&%||KQAaqdQO6_+(AA zRBn1Mr+mg(3t7a`^x+imUezu_eq87-!%WAzUB~w%@)+!~(l&pc)2kMAGQT4AUV;R3 zx*em>R*_Ihr!H<~(GT9O>rBbMSuTfvng@umGksy!<5uo|t2T+Zk(Aq+kg%nrd(Adz zuw2LbAs0P^$(Sd}GOFLixb9R~PuI7bA5B&{riX~Um_#G`Vz8Q5Yc3AIJ$pm{ZM;6bM7YP9kd%cq-+pU zIrAmql9s;rO50nEs7G`qrmNc2R$DP8JBmbJ%P4$R{;rN49fDfy6n3^BGrzUjz>`+fbc+njvauM$5n*GTbBGoB$n z4tm|IACS1IxYt~&HNok7D{JzZflsV*U%ONGCFMuP{^;I`a&y;-IA8R@ZHr&SXv9VR zpbGXT(|Y5>VNQcel7mU!w~Oh;Ubd%jMkfYlVULfTu3D#SrI9*{-eZ0T+n`S%UDQxy zzaCbQ*Pt-C>Xuy}FN39UzZEuEu;%N>PlHpq6VjfO-q)WCtT!qitT4NA=kfJ+&2>}0 za{02?$oxIM17Dd-UyQWY4+Z^v`}np2!kB;P)T=`2yEiRNO-gtvH7S#m%6HHQCPYTO zRWCzP3S1v7jSX1Q?Pn`wVzEwfA^169?q|6(yyaG(`_pCqCY#3 z^6FK=mR{BEPKPEpzc1r_UnYOIv~j?MZP+Tw!Z(8bC(E{Q^l;YXyY2StH7~E!ENbkJ zf54JbD(+P9PRQwsepol}s_Lrdh^`2gjZ(Ec`}(1*N~Ag9M(^@0%O+Jzd;s5BsC~D|VW@x=hNAM}mM}-cYj|4g6{KaHCGd2kY2fLlS zqhb)hd9rE6ccxXx-};73u!SRC(g~xtc#H2%2Itd%>@C_nw4QDJ!P$~88<^4&*LPj` znOk<_cE2WT$8_Lp!q?)X5oY(BdGc3GzFlJ#XjP6s6*>LljA4aYb90#UsmZG;8|adY zci=7ZYl4$(rQ3BToHHz)o^~i7{4%VoJn{N?)Xz;WlznKX>Lj{hwqv!^<@>9fi+P^% zcI;w!>*W|8Zq|Fb_JgcQu;1>$+X4o0jos%*ev-FqY#tMl-GvmI$^G%ZxN}!k>ZQ%M zO+UmUd0!og(z=V!Nhrztw%KwAJp&)zpQnys@VMafpUogGcQCDlH`9ZEj^LXNA4B(l DsWfhc literal 0 HcmV?d00001 diff --git a/src/vendormodules/packageTest-0.1.5.tm b/src/vendormodules/packageTest-0.1.5.tm new file mode 100644 index 0000000000000000000000000000000000000000..3aba1ee9a55795a713f2423a33d4e2c2277ff70a GIT binary patch literal 11963 zcmch6c|4Tg+rK4Clr0q!cPL{Q5o4Y7DJ8oi`7$hK39CutdDFEo(y^72{_0fPxFTC zFa(G|LSu0hh)lteaYQT*s|wlR_R#SZ92LTWHQ<#89Z#U)i4fT9NmYhO6lkv}6^VpJ z(MXUViB6!|%lr0wFpP-bW=tG;cHw!UfPMXbcU9 zg=GCmSTYH#LPleJ(Ox)}y*LULPa;B|BmxW%PlW&iD%uY>{RB;gRB3)pWqv!*3rECJ z(6CTC6;Jd+0*J6^B$9ylKqCFnzBo64!HxA4QXzSIQgJj|AQ=atDHv}66VeCoVJjIz z`ZPc0A9GZ~dqTlZ7&Hyz4FxleNhDGH&;)!C4sya1JxLH1L&1}2E)4i&cmen;c#Z_v zKsX8om{Mj62Gc4ux(DmADzuY`_5c4rR>w1uG#pg%85*fn;Q$efyv_PE3Vx0eC8n3QfQN zzsD~F%>gqP8gK`!D;7_ISa85!MA-E+c;;-LTJDA>V%8d%bc2su&71U!woYDSof%aqxf0;ZyJ&TeKj{BAXXSZz9_Vbs&|7PKUlM5ka_ z+Wl#t+H4^p?&lz2KsW*ww?K%=&Wjz`B2CF3K0rs%yl-r z1^&$4w&{Pp%@A^$b@-n^!Y9IU1D82D)I4?J*YF2kf`a5W{dK`6NDhcuaLK}|P9Ge+ z@M}*J1&0Q;B>*6Ug5kvoxd4Sf8gAC|O$)>TOOYx2GON>6a>GIw49Dpm@HYX31!xN_ zI|VGLBfM;3MHYTK6$cC2Z2k^deF6qe#ksL6u^ScV<%c7J;^YKZI-(aSkpzM-`@VGgn`T8EYt)F zn&<`E-fZ-&((N)U4}UuY0uki`>B-VT(SnN(jsl1Q>|-nhi=XE+SZVm<0rJ9k!MF3{ zX8w~oW|Nzv#~;%Gc9bWbK$v1BkdqGy&=4mKi3r+1G*<|-Z-D*`OLl>fNLWL7FU0IZ zBu~({nbZaX%mrwUg$d2{BMOUhEvOqaSl|-v29BKSDQYZ(GtmSqGUfttfjbXakHe|} zSHPrdcJr8b#vi)}Z1Ud?085(Eah{;*^~}R(gZ-bu;hQIz={aWU!jSy@K%1vR%-n=o z8X%&~^IRZ6kYr^36uz=(iWeQO8-TvTd=ldg$1R9A66688AYe-%$KlsZUOdfjkw|l9 zZ^Y3s^FYDc%Hq&)=uWW$Dw0K!r*|=NkwL)F;OB4@EGz_&RM3w#)HO6!)OC^2Tp?3C zSxuTLY+)f-5>cK8#}y<$i;KtuVvZw1G{6esQuzxJ6%a@&2~etO><|bp0uD{3L0&Ke z_Jb)A_{QQ0=s+q2h`2wVh$Z<`Au<6?1C1s040&@3t$Ps2edt8G(}H7h`8 zl6=b4kUv}iz%_wFql0S^d?_N5fa}OurcG3)m>J8VzC@BgxR%U`T{uKZbQ(mX1Tqar zTi7}dUXpomf^=6~!XGiZU&AaJ7vY#aYqG_d2=Oy4o*Lz{8QjB+#XV*E!CFc_xQ zs5DRte_cVT;QDE3XgDi$r)n#t54#0ihJWRQA>;|#9JuQ{6FopEPN{@kXz%PzQ-Y{; z3>M< z2h|Uhe-L)8qVI_h00GEE0w?m{51LOerXl?K4a=vqBYeIa7rZq7e);>49-d}K%rKe0 zYs2Fqz_CDzFo!VAhQ*>UklZX%_h+mNyOObR6_5qBh-K zxShhS5GES{9hk7qjGe%h9E=~}D>;jk?8OoBU>PW=zvg6s{lL-7+6ue~x8eouG&NNC zUwV0-$iK2gSx+>9-~s3@oKSG_2MIULq2@_~6GhfylPY8n=mnFtU;wWN-4iwilLh$U zu<#fH0(PT9Dq#KydL4MjiW9(O0H=nT0d-+V%uh2o0^q^QOtJiH0>S&IEAMaod`7AN zvfMKX3e^je`4y$`xOGO%3^f2|V`(=XpWu5sj6uHyK4)bYOcc<2LFHu*2U+vk-==)i zb!hr~>H_ZvV1S&J+2#p|6>F}`5;=REi>82JoDr`wWp(Dz5spfh=|OBVXU15_BM|UJ zA|3dCYOYIW)>q&vW|5moJoutR05d1mKc^au_BW(>>m$=<^2~C|9{h0;KP1_-Z@pdr5KfhUc{cjUm;3(EL;lDELJX6d)W9~2be`sa`9t0>TroTpu5>{rMi$vMj z*m&8L5K)dkfk{&8;3wIdjZGCio$fzVRm%?C`c%|a*Q;u&&3giRW0k&d;+ZX%o{cLZ zdD}xA63n_xHh&>Yk5&&&agnb(GjEBqTA2KK^6E;3bW7=?2r&I`+o{ zJz8+{LZ`{8mSas57yO;VCF6 zSk5!Zzhd#A{2C=LFZn0yg4|dAJds|y!AnN4ajbSp-%16g@@6$1rx&jdRW%aZNhvt- zdwr{$xC+-RNku&nC4b>+<8VivK8zU9HI7Tr`tZc4xMxkPU~>8?gcPQ+AJMxw#`)G` zdL#QKgnQ?@57FM@_pIODf0NyRsPxAY#2BX=h~=TPB6u z_x+Ikp*IvNHko@l)U(9(#y7S82ZBbWg4fxk#^_1aZ=;nt^%+U#6>VNQKVFRP`?NAi zR-n=2CR@(NB}P!haL~Pt->$1JJN6E8{6~LZcF{+}#qx=mJpzw1OdmOvu6h$O6qgbb z6jXO3-+0Hl53%W3;|`A_n@6y!+IWYWeg9@Tx4gM^9cqyJ;LWgA=NI?xtB_IjkfI2e zzUDbyuNrctD=_BPP{Sd4uBS+Wi6N5CvJ{#tU+dNfxk{~DN~1TaA2_yEJeHiY`ZhN~ z4$H&tlfGiqzjO0VcgYM+XSt)52cr&;iLupxCE=2&saWTiCyaV>0}&_Xq}A{py-oE^ zjCkFxbwy2Iqqu%@JiQ+Mg~6$}(_Ze4R*+7v^R7od=X#AUY`SQLv=KiS!$=?)3q(CL zw~lbRujy`Rx&N@Qn4-rb!&M=+T<%ndkXi6U5O5e>E?Fs)#k-?{U$vMxbN2q~1yI+q%!+|l+zLpi6 zEgw)ZK42N|5@6om_PSQWPMR-jd*jjV%BaYF%hw7w?qbVc{OnOzO1#s@eM70_owWu{ODyYBtrC}+-?<>dk$f=1*;95yfu2u$Zjf}luajS- zZj7&l-b6x21p=?8U+h?QZ@|Z<|9H)V%2B%lw#n|Y8v{CC?*w=3N*|Jk6sX-n#Up!D zxrW3=G6NGMl^gorclqB4$i4RVaHJ6NZJ2CQZUK89Zck9t2ewjKu}6AF@rW~l0h2A^ z5`NwZBibmoAFqFKw}~B~W!&Ki9O9eMZcyOF6lg5Y$#M@WN;DL|+;Zghx`&U#9v92% zd5LC=K0jx|>szD4BkJ(_?fqVj$pp{pmv3!Pm4-WSH$2mD<5^&uKzQE2ntGpP|T zcXk~4vE_(l-gAK$R!QX_rHI0~;X#5-s?BlhO4V&AlrsBXMj~=<3QTfowQ@@DO3Kh} zXm&Tjti~?VT#9R48ecwgB<-|Q^2w&i`)5Q8^zFD#ef~;+w*tk!N#P953|iUU}h2M<*U)!X6TgVk2g+Q zy#Dh#K4P!uRB^~L#q<-*qw6^GfqZ?J1&d#Ab=CvPZ!=p@f4KgO#3Mg6gSg*Xvig(*TDDYL9Ie5h@(N*(8WoKf*AW?O zl+=&rY^>gTEd9*u6)^}kUBrQu7$4!>46NxXY<{cnatEYcxWbp+D~v8g$J-}&X!T!c zZaRBvl0$c3!e6Z;er2-J&CuFvi)%IEgY1{+>4}Wq;VYqPnJ(WyF5Zx`Z%x>3r{yAQ zNa(P)Op)qZ*}PJM24E$$YpI=nWz4^ z+{yIQ=A{oGak;gx4-;$pu)@PUr=--|z3uSV^`a?#*^W84(DtDtqOXgcn$AvM8gjRl zZ;x4+sncZG(gb8{mD`YNJ9y}DtXlhH`eNV*he&_H{!%J3buk!UW6$Q~Ho}s6{H{dTI z4Ge_e4%gFDicg0;84&if7rgF#Zhzt%e(jRvF#X`=MP|k|)+U`FL_$giJ5+>JsO;Q} z(PeVOONKkmmMmWW2`!PK^KXX!BART#m|TX=9=0J#(T%$!j(3ieQ6Ek_SW{3R0Vm;wC(*NRW-p(_VzTbL#|8DAC#IbUvK<0B8}t9 z(Dq$r73l%{^^Z1cG9 zS~G~R(bqn$Sp3G}8pe)$drWnW{&uz6*S0q_b?wV-|2>OV`h3;z^RvSj3f$B(ZO~7P zd^}M#UJ2jRlCI_#x1!jr*i5^mJNB*4H5-&uxMbonTBe&yyGKkAbL#KSPut2Hx*m-j zua7gQ_YGG1`M%%1(@}-kGI8GCejp|KZLrCj@;<}LeO)mJolCNA6F48;!0*ppW347X6Y8Fgkgt%|`3ES9_Mvc+V#~>1l&`%xV`QnBkniu4I7shaQlm6^k}Z1oPl zVq+(3ucRCARsPpYZO_9--OmEX#Tx2biE&(#VFfBH4Xs3uA5@S>Zw#yNFI_b$@la}6 zWMOq|j1+E762dClp)N1qYMrS(@9?6DKyulRys{qR{gH-%7ovq#u9s~);|L8WFMA`h z>D}pSC5E53UfSz@@z^UEiBw{a^#x5i0NsIoQ>T^hh)00v6 zGo3j*CZ?Lsn%UJtXe7UaY&?9Jt8C)xc?23B4* z`+4r+Ph)(CeS3a+RDh&MgxqMkamCKy_Vq~NXQ@lwg>j{Iff22rXqTJLCS(LLI^;iM zv~HcrPVMh7y<-!n-n3=YJ>zS(6)8%t0i)LxDBYvN8I|JuO+MGh-I6(2mSbOy4(|Ua z+RY|eQn-suQMS4<+Gk(uA;?SM8Qkct*V4}|a%SBb-9)$Jj|)5UyR4H!&*f@bmGO-A zUG@y@lS%4$U>6i1gnV8VK~BAe+WDqDVRw-nNzd8VYMA@PgJn;;oF7oFv`}ph-yZ3S z<*tieu}Uf7>vf5dtGYaEIqbQ8<1Ldi6Vw|YT|8>Es^WOqwpX?64^-uEZL_(5_W2OM zw5dmMFMqR#t5tJXIiCnmdHvdE2OY`WNHR9 zh915~Ejq7!eXw5mc0t5g<#2u?FK5ud?=)i%)T}-KrO^GU(%w|b2iVl0#e=*pBl^AW z{)g%vYw+rCnuaP3%0uKVSLJ^&DyGP^4Yislb!}aPl>Kq^MQo8BPAL3S+Re_TPrr&X z5*J+xf=O`^g_jDEyJsJcZ$9I!6$6@_`-1E#y7bM z{vX~##y;X1;>Nq#n_rr^N_1&l*H4yV`+GCB?1CyRF6zAeu55Se`i=sn6w9XvpYVRmLD5VvAp+8@EW<>k>6hYt zFoly1``4bZxg8#9aMlnVu`AW_UV23Sf%jQDTL!<-DP6)BGeb7xen!2J4I9y0qR%c> zwCwmP#XVLJ1|QdY=Iyt;OpzityX|ZiFWcY8|J^(O#K$_vi~e!7c3sMLJI^=lLJW0U zJdmZ*AzT>Cf$Q=Z0*C89;ksBRX?D|J@-s>kfqUMgY!UMEb* zR%&33hrIvXs~xp3D$lw3A2T_sN#ht;zrXF$!{q^yCozWHTnbQg`i6V8>u$8<3QDGb z$b_+k!0~OMpR_$GD`{+7%+;GR z>4@ZQk(;X;Hm8Z|4&9Y-kR7h(TCWna!FxO%vOzqBv#F*cliG37}1)48Ho^? z#kFg>%d`5&?8h>RZH-TtlIlV+BkHxoNAUI0%TU+E|8Zn%j3+Ga3^My>{9p-3VVP1Q z^2lmchjC5UpTX~5J%3S~?p$GSqgmN$hlu75_{Znyi9LrEO9zHUE5@;0C4OqIrX#*e z_e-tZZOu>+Iv0Xj)oq&-8TThb|?+W1ewOLqNyuV(h)ErQ8uwB>hiL#-9XY2CI z#!8<<*mh`?8D%7ItlBEo6S4KmbBW^390o#df~oHLcvb1^36|0Ldoe+~Ud1=qt=n=4 zW7;{aybkMMPt5Bqe{n4%2CKga(LsNsL8;IGG$JwfuAJ??ZlZ?Z#Z=nr@?;a9W9t$P zs>~HCUsv)F1+vfK*zMKFKc0MX9lg?QUn$#mAN{`ACLtXo*B_HTe(whAU6=YV&X&7B zKB=v+G2n3W>DcFn7F=5QPBiY<>!SXI+JaYiiZR|AF}}6Sk3Q!x5J?%wId0W=1~k%BV$lMt%17yY*fFuDrIOwX@1&LuY!y^0f0+T8GrCB33^h(76D|~98s4D+5R=Buu-0qr?v)J zRaHA&w)5=i+zVWt$i@qg(vRKN6l++c=R-qvxLiy-As*!Fo$<_ioG?(naipz$V~ys^ z?w3a^YL9cLUp?uq9%K1Fz6y^DEiv&3s&lIf?CaR5DmhViQ0an!w2$$=!4bir&m2{X zFO_bDp}fT25MSMVW%~AQz_m@|j?%i$H#{=YHXq`+6vG)o<#w)iE^Y&THSeS{7CQs&>hH$0uZNTx~Qn2+ZpL*|;%hr(?L9X4qAZ ztg(=y6D8FJ2R?14CmJIq?9pf&ox-u;?L6t-wyyk#;`eB1zxrm>E!-fuuVVY7ChnX0 zH{Tb~ZApW}@dhnQFFO`}$;fILGaDUnD*7R4Wya1S%J%2!BN#x=`uxvkkyd70-0)_0 N@Xr~1?}LwF`+wp)XJY^W literal 0 HcmV?d00001 diff --git a/src/vendormodules/test/tomlish-1.1.3.tm b/src/vendormodules/test/tomlish-1.1.3.tm index 8afb43d956b0212bfd728b88613392b2099993ea..83ab2c7ec49d4b6743c4aea66c4f080e870f17ba 100644 GIT binary patch delta 5874 zcmZXYbyQSc+lPlk=P-!G07KV^q<~1bARr+f10n*_UCJOKNXwCyZs`s|N~949X-N^3 zZjktp$H(`5*EfI6zOU>4?Q_noS!?gT&iE$Kbq18t!C{RYAqIC1bHfb?AP_4N2t*wG zEXx2ozGeXJ;W%hRI~TYJ*?Hsnb>nf}ui1cp*9>Kekw<;tjEnI@2a#-N!@$fB;gF7Y zD|ePM{m={FnV4ldqD7Xk*#ox4?JGH~)d+EK19&9UvT-G6aKgoVQa;>u?4%pdT*)g$ zbQ5}?^XNlnxLKzH_hEDFHyD;*g$rIUk9{|jm-`{6!#@IzS>;IMbl;_!I6{H16WpyQ zN|8U|C@JT80$a&mTkblQebH)}#7V~^))aDl7sUVZk>mCD8|(#WF1Egag|*bU3*sU4 z8&=(p-iK$V8PMm0Vjrbv`nJMoWbvALSPo#Ch2!z7Z-Tus>4!H2%h6$YYDUe;=BuS; zht|IQSQ2*VcJDz``h7)ldm^pi6u~$C(sU%#PlpG2)66|zIOJUpLw5&uTG)7;6x){kkZN8LM|pY& zA1c@2=B@~$GImcHPtT5UV8UQnOEBl8MY`PW4%SQy@-0?qJ_j#0e!f&b(PAL9EacAQ zEXRc8wy_tc_+ViObW{7<6l$dO2U?-hH)Fmhye_e4F2?Y^NsE36;qBT-gvUySw|(x! z+fx)Np?{*@KXW+fY2Mag=%%S%(cD{OGcvn0SrNYNW#_i>#72+S#fy=`Wz6Qs;A1V7>UHwr zxOL1P*NX3E#sl=nVH~80cDTjK7!z`PF&{G*q(ULA4$YC<2lh? zH>i5r7=Kjz%2(kia&4F;`&cpb;xXrY{*M?yZ*pvdR@A95R!!}bJJZXVn(^KjXVr%U zx=xiIZf;)HrLOJi4<)nL#==40_n);A<7k-SNlQZkv`%$zypD&*;jyY{J7FnT8ot7G=A$6g@OAa(fPvQ%+5y zrhe{vCAR-GNKlL-9EEz*dJg(06Z$qb#u1wWIEQWP*B3WBY0bgD*R z*2hY8GKRWzu?%%s%;x()w4_r;f4I=ELs#6tZ-w6}w!o!*NT8=OsPMLB3t|zc`q-&Y z=j}L`gR0XRl&OgH2V=3xVN=JJna7ud=#~Xransye=d3fG)Xs!DVY=i&31l4WRKA2F z+;!?QT@HPivNtkN4vTt{GY<|U18Rbh#J(}((y~YN?eom5k}>BVswdF9$?rUe?0AiJ+wT`%Pwx&MX&y zmY3`}8h!CH+z-kCMbqV~9+h-u=5-(XY@OV2i|_eC%y6Ni?CVe+7cE`M6W{P6`WIt} z`gL{tcD?Pl!#KSFU&ePm||(m zl$iw2+u92lbETk(lSc{hmOmh03L(u+*vE$Zudmyey%)C;r5@W^@pAhzK~%`!yE(%5 zCJ`xgi%Vm^JOwpLP=vCVBW(%4DWdl!T~=?A2I>FxonWnFYSXDzo9FWh?~jXU8iQ*S zt?RAA)OOSUAFZmtYRl#66`GhMiZ(`#O1|nEncJO~Vy1{EH;HUgO^^l%ow>GqBz#H* zF=@2gzrLTw6K{89uuUQ|mzdbxte*Jp5zx-i!?o-*+&O50c`mGW?vk;h@F}!F)crFL zLEwU?jpMRJZq>L(SV(7_NbOuFdMSp4tL^(I#Yk~94f_$F%HcD!E^GfydKLFVx#*D= z&5e;IL&&h5jeJ>sjbnqL&*PsB9o34QQTZpK`TRd*@1Zh76YhEF``DT+l_#mphcpOP zZ}S`FSf1}0V0Yxiy(06Kk!P0=0dNE~qSBS*G56KOmY58~ZXvenKMP*dLXS{AnTSi5 z%o3<%h!!T$ah6`TwFulEXVMlIfQRsSS&^;J$bJDW8Dv-o@pF8~*L2Lsyb1X5EqSvH z$;-Zmo4p|=W4)s+_!B-5X2jNWluL_b^3Fx5#*Jkjw$)LH zp?dJ1An>9{sNlgo`2lfV=mBpR!J8ix4-NGlW}ANs^Kkznnc6wYpwP~lpV4&ed%flC zr?eGwue{dsps3Bt9VWw-D@^1JbCXp0GHfDM^?B?^x)$nb( zd2A;4kjGHogM@_==NNcKfYZpZeOXRVSIRK2F4ZHNN0#UZ=^yArRL~P_i*$=$0)D#Y zt0n)SrFv=_|3pDiFYB=%v*@UhJH%7cm(SBlx-X2Z{{})O>F&@|IAIeIppAWPNzld3 z?0Z)i(3Txw(aX16ihfRRPF-bswrX3ZK<#<3kO&K~{7GCOO?5}&!qLrZ`yT(&V`pr; zD94JXow}Dsb)mN#8ynEx$H{KkP0T^c!xnE)d&WD2L|EmplQn~Q9kZ$JaI2At^kSB_ zRfos?-QVGaL$$VROt*vu-P@giDJ{g5svWIp=>_Z~S?safXQMJ#3d1rz#%F-ZJB zjKPoiHTve`o8XP=iA8$+MpYxBhHtNYm!8_w`p<=YiXti^rpJhS|sH!zzd zdA9#j03uM#Jo@b1sFUl#U6tLqIDYj{lAHuukA}IRE^^BQP(q3bTS18&iY&c!(C@8` zGVy&9!v0Qso!XUV^ukYG-o?J}e3336tGonXWQdHE76#sPF6|VPl8V(0?Oy7ye|$?v z<=VNv54yl`1aCIz!F1->L3Of98ZoQwnqQ2`uHnq-@U7*Ulsju2{31lWQEK+z)E2eu z-mYK`F?8*Bl_aT@b6?N?=*-@O+UNQjf=6_mHa|c-i1b!;@-Mo=B$V*XS8MVNTH8i(yG%1#kDjZg5mdc&M)cAv=Kb@@QK-d z(mGA>jxQ5mT~HBo}P zMJ_JCC6(r*1bj52ay+>{An^2F2jtEVm;H`C+Y!uW{aVj zopWw?JFQ18MfB>&54cRvhE!L!DVmFl(Y3d~8YNLT&wfCYi6*}wS+=)TF|SUzAs92E zpvg*0qx~X@fpm=4!=gb!p~|r7#XFC_s0}(@T@;EV7CG9OT(x6GrQ_yT(Cy&FcjK22 zLd#pS^tEs`=4#04UXBvSOpj5H#2HtNZ~v<^#E_y}xQ*B$*qwEOp?(h&iyQ)h;6WHM z0t_w-2Z*vBh0Y~JxLje3hEMvp~LrNMz*8XQJ?1k zgJOeM^okmN?8^I$1#O7#TMx9XpOL3I&(u%o&d}!HCP<|9wu@4D3HMPhWBG6|v|PR` z{4R|OOfEk*C|v7ErE~lxZw?t1F2IDCpqQieiDujCb6;<5{s+f#v)GS z3h=K_;jASZFk33U&9;8F;Zo9G`6VUNH3TT|m7^O6S&_9U64$8#YTzE&|t1b{3Nhf8N9UrS~PDw?wyV zbGgc()<lJH3O zs`@csLKOk{dL3<1@-WqkYuwL?%)L)!X1)I5uwmR_x|ZLUI|x$BjKg-L1D&DTm^)n( zzJ5f`vRXRxrANO$ZEn6>PR+cVSk~XYqad4WOKWni0;VM^C4jZu`=H-^0uwhaU^BVh zQgSn{jUSC|Zqk!Tk2{hzR7=aobWkwT0apskypDM@_qZKBQklKxw6dD-kzCX5(0qH3 z*87*7gLPdmL0aFKzv@M~@!AjEf!L$iy4|}djn70O+N8Z$Ndzu347P;#9F6X9L!b9r z>rG>)-yoHr^5i>QfE}u^-HGa%XzUxAmkadGd59q=lZIa;BMaBC=QnzwlU*HUDS*1o zTKT9ZmojD^Jv8w~raWM#^?cowr~mkY-`GI1ZeHLQmJ3^J+YwQ~6WG6VciAY z4@-0zZb;|uehR9dHu@Q9%5|c5P&uhNmfKPhTWV;4j;~&uO#8?**1znX*H<(4sK)M0 zeFJMM?^7|n!=*l!WSSY%Lv)F|<-h`SDw-2XI*2{}9!r0bVjU7r*&MkNSJSf%L{}%H zzaGgQx67Ybu`RE>k!g$#cvpXJvRm98iQs8fbopV{ulKaLbnL-CKA{FI66()eY!ms! z>gbFu^^^*gI#$?FTWo??X=Wb`uURqpQu;ou&%P$ICC9y!lCg??wx%X!Le+DIqjZY6 zVpd*9*ZfP4TPNQ7M%fHk=`hZ$v5xRJ^tgo^ZrbQg4N|y<_w0^^-7@S=Y2vT;coFWk;vc zPq$d0&#+d`k%_?^`ojEOacQ*j-Xp_S2Yp0k-Te<^J^{Qgvfi?l-`sTql$vHaGSGk* z#Yhw`tyWBny_D%IlS37lYvu8MAdk7S_AaFhtw=7bsF!r#P;GnFUTVaYq2HGwW5t9n z4*KPF@jF>i7UgK2rfve&$gxL=`az~F#&64Q{SB^75@L~CKO$Py4dP$h*Uvny?rl=F zM|EU0kLI!&*9&0mj%JEhF02dxnnh#ncfR{sLieMurYm%B&2{1;76qqmcAtIlc^j9u z;v;@>V`68c4*~xSUBA8dB2Jb?)LU3i<1G{KuEx%GW1{3>Va*1op$O3a&GgP~uaK<8 z5Ae~TPOtr$AdI1WtK;>cJoXFB|LmMV0kK&O4<@LWf&4~~8eS; z=o})@DhUBRqrOtfJWy~j2?>0I|3NBnD~<@%PeuSnv{$MkSqSK$yDEM7i9y~sNWhxy z3h70O!OTlEX8(%}V)$3{Ia3gT0mqdl6~_m|QjoyzKe&}53ea+0b+%Gqphv0zpw077 zP@WLnN<{(&ynm4V>QZiL2*82wN)4p(0i%2%M!FMle<${h{1<>NI+Qf4^mwH($zc!ARzTe;euNaaKQWdNMPoFRk}7l7@bW7e#u7w z5z?1w4iHfwjZq1f7qNja3akM!MR2=7ADH?*AVK%Hw*ddUpjiPc$YLx2B8rJX(n17q z{*OvGrUvZ`k$|J}RYK|^E=Y}HyGk8hrk4NJcwjV2`bx(XApqxlf6~7-4wzhd`NtLM z0f5S1U1TZ(mK7s`7ynVbW}=sh2vjdY0A#9vl2CA}iV!R<(FaohRrf*PQY0Xx_V-$I z4<*5`CBz_e86EKPKibh;{OW<~$`F9s{j2nrx#*RWD@OoBS1QJW3`{OJ1WeR_2VyKV zK>G?Lu=AT3Kq*%eu&aUxc%kzLp`fol4#-_81Ptl_mx6)0l}JF<_>Uq5Pn?KBXcZD8 z3xrkkg7;ma;8_h37*vG-7$5$f*Y8dSE>|G|b&LN}xZwSVB%n?;60orTtG~a7ajDHNWM4w|wUi1a zt%RX8+4t=&eADFh{l0Jhm~&s(xz955oZorwo^9y!0#qfyhd3%8V+9H1kY?y;Xf$}h zSeyv3&k_ROd<;ZOYoB3dR74uF`&#BB8eWn{Xpe3^gLRcn>~md(&#}0K+P)ZJ^Bb3E zng3ll_MqanfL$iKr-{$kGld+ng_v3uMrx$cN2iAyhxF<&;%oFaLQ}6xciJ*|>eIm) zTpG{!ghp1zM#iPwtUDx`&KT`)SS_p|p?D4Xk(2f4{qRL%c#wptL(xUaffi)pK$2=!Q{)CRO!8HO))Ftlw{BI0@pSF@2 z_b+){Vu1CqyKXdn@Od5XfSVa#r=|N;x6uIGkoAIvL5;rP;}nzUp=GW+4-f-)+NTdB zkqXIuzXgkGh#^zKU($-q4+lTKZnottpZ)@yohhNJ8^9H(d+V^{Pj}vynpAh|S-9e8 zYO%RwwT<6HgJR>d#{#7Ww`zLHw|K3L^s2M!ku##_AEr*HA0Nbi=wlI2iGLQfdD&jr z!A>Y~c`Liy);;XoM|8b_&a^@DvQ9fkYtn3rShyoU97D|MNM6XTo=C%@QQU{`>U2#) zS@=>y6`Cs+MS#rBU?!P-Dr+!({WXM?(()U(6F!FQtKyD8ZbEN+YN~7%?NNL`SW3jX zF!Qo|osSSt%IA*qw19P~@^sA+t9rIepJLgA>Q$24@yb_s2j`S7nk!c|EL3WbjDEF? zPXG4w5%G9W*_Gcr;|{7VJB!0>dAFQ@R90g?RSJb2jA&`xr9T&bcVzsHbrZ|8;GBxr z;Z5QdZ$=ER1l9EN+$PU^zjq0Ub<_6r%c$nnF+Q7mFg(dc~sOqL7Ho*<`cc zb2bl&H$Kxi`^zfmx;z+uAf}|c)^Z^K#frvC#kDw;X|&;JywR*{wDJ#0pPGZuGgBKJ zRpW&TpCXTM+bhuK1>$2YUTHC45^2rZ4?eXJ!A)*;w#nrLsJET1Z69DA%-mUjQuje~ zB;ecobuV)D;|kK6QMoGHj8{-8*~_AdtfVv_Li}m`M#@!2U6n0GAjGN6O4_Hm(J0}@ z>!-KOlDI593oj;F6uINjoGlCJn6W}e{BBn%I?2gVJ&M(z?UEm9OX;ThGe^((bb60N z1KSf(v3d?r=t~lEc3T?uGM9cmaU{*Nd?si6Tj;0m-XMkQ-Z-z~wL1$UZxbgCQ9DMr zCW*mt(!!yxLDV3O$4vHXo6{xagx{#1@UxS6*XuAwc#J0CN#?>;8M^Xt_+PC~!F$x4 z=@?pA&_-0}rZ;9rlym84{jgKD-Be6nq_K)|e%&{QD|T!nrN&>gRpeeMC^6*oS&fEl zfA4mxIge>h^*Ej2*Sv6SshKv|)@ZC*o9G>_`+6Y+a9)ZhVarVEmyGu($1A}U6#4wJC4gMG_;kxQ38+sa=41LNS zdXhL|@=cYaBai*Yt^+FAN@{9h95gFCTyrK$xijr}p1rcHSqIj(Ihw;vFn69og7s{c7Js#ie z#kb5gH4gjfB#w(^KJcpN`}Xi$P-71*k}iN){Bh|vi7>v2in{j>wKRUK=EiA%LfLBK z_xO_HTD4`1jEt|d<-7=#;JYgHghRpee57dpzo88n#OdKtXqZm7Jk_*I{_0aFOYNLiFQgqIW;wCX`c+A|9rK0Nv}kj zcv`UEMkIx{AwX_uE|>K5ZA-LM`E=XYm?m7dK(cKm*u3EaqhVt?AQWl9n?{)N-tDyfglc%f)rIPyg&WqdZt4va&!{ycNT(6rM0= zX?|YGbEHwU==e-lPI!HDq{~jD8@8U8u z+f6JPTz%IToXHb~E0Yudnh+}Av|qSjlSex@^~5U9uTD2`Oy1+eJblWqmjV5UXN6A` zyp0kMkoXwHw47Vms~q*-RcRwlSIW(jUZRa9c8ZH9u~#SH_5~@8v=kwg69X64v6)1@ zMxpR74zFQQDstW>II5oFYBTx=F~NY-Q185VltQ|NJyo?Rm(w?)u6H>_2kE@5#pGDgHe81s$e zbq_9`3FF|N$(Ed?E5TsU+wn-TKk6~@LxbYdy!U&&AaUbs$b8_-kuIIPKeRGr^fR}} zg`X7?db?-Q_gKwL9L(5boLLe!zaZE;*_FFRgAZ%ou7tgE*ZInjld$Xsi%U=L{oy0q z&hU`~zN$-?!V}LT+5;0D;Av97C&k-g&{akDW^b@|k|CrVyuLojNnU^cZoO=M_TNzU zQ1zY+6YWg`{-_S5ul{d&cgKj!L1K8wr%^dZDXZTqKFhXQzb*cJYb=V7)xF%Vxk?t_ zC7s$yTdA>lchsk^cGLg5mWU?uP$3?$7$5055$dL%jk+#$;PMG)$x<7U@RrsMn%T_^ z;4=DsSbhtCKQAO};d5VdOLzFi@)tdY%YCQMpCue_RtmO~_Lhuoc9dbgNpvb;a*fBg z!I%lxKBS=KYLUDNGIEDy!+?_PkmF^KBmG7K6-c)xxh(6~3pno^&#orvYnQ&i`jMXd zPNa7cw+x$&q*3{h|38{JJam?-WxrTRy|TIrDG)`q#GQFT|h-FY>QO+f%lJ_yXJgut6t zG(GiJuCYz#XQVwW8B-IMR!H~%Yg@UjFerr{;3(y7Z`Kt^hylQ4kAN%La?lqRkdmVX zJh2?WIfnz#=J3I809>{r;E+O53>HGMQ4&I+G6ZD^0i4anLZ$4~uqRg$s^_4D$3RIQ zE6~luLT5SmPz&1m6RLxM6nKH=JuDQ2q+;I@0nkA~Ev`Kj2R>zRa6TUcaiSo@U}C@wd>>+=DM_ljdXg28 zC^(PZLlkvN14AT&^3L4<&`MLg+X@vRcWJOx=m)jSQkr9cWQ+pn5)N?Jm;=6_O=Bvz z*C{~#8+3~>(2N{)hU_9W$Wb2PO4NauDJOO4kzzh*^gqQ%UB03i134>DvW`s zN*D_HDN-67*eQ{RkVp4I22gQ^8AO(1p=W=UeHjB-`GZQ-4Er)Q=#}!{@Eik}D8s@` zfKCY>*i&fc95Z!)9_1JqiE3Y$YeN&N)SddCX9K4zu+VF@ef;ylzEohK7wUV85vWzl zLw?8hv9wYRI;26t!vIl*gO1}UhdBv)iv#0TmXHsg(qO^70}Jr2#zNe>luj{l%TW;^ zYT>DmF;MDX19##D7an6FI(=$Fq%$LU^4Js#{SOfU(*y?yXSqM)KvWF|#sEwyk2uo# zIK^OLX;k8H!GU|VScva9brud6W{~5ePEl~6Q-^^H|7s!E6QI8i3mqX)vxHpPfe#S@ zG@jT%ul}k?XC`1*PY<-j;K0^RmXgf|xatKUs}p;>`_t_TP5ecYI|BTww}4zuQhQ16 zy3`eW8ZglEe+mf%8{J{CAiw4iNcKg5hDJGv&y12UM8QJ<+k}N&&h8-^Ec&y8G>RIx z*i-D_MlAyDQk06-zG@C(2Xn1(5YUW)>TLG4+Epa@*o=j~+wChiA{rR9V4*FieH9+f zDQ#*9gHSYo3&sCi{L#>8{_n}AL`iP@1KC>Dp_ATJq+D1aqE!yc@ZCcKG<|t50 zd%%EmJm-C$_w)VF@3$Cc_TFn<>$-E@d+oshoq5su+Pi^l?47_MFMF6BNXNol~yepV1 z$l2Ay1qSl6gLevi& zXbW}$LoDE(dO+=6Y()Tw@UBHfoa`+{M4T-g!Davkv(s-u9IiGtP%sSU;|2y@CWIGiO3kQmJQvbO>G8CzMvtn5I3CuF*~LYys}?0vx?V|y1HR}j<+V($hs z^@ooPKLPm9?_3XXg1`_6Kqc*W7$>a2JS@q zEMRt=AZ9mLDAXQ)4%EU146p;7@AyDqcMvTt z=*A5Yjq%BZz~1&y7!>s5_@Bp53pxkpJTyQY@VQ#sLqMl+fd5?JqW_8K+{NEdH?wfD zHUre=`!x_(SJ=r#r(M7-?45pHZ+fl+Ckuc{TNjWq)Xm8rc5>Fw&NxiJ(|*#ycda~k z^@%q8l{Ek{*AJD3qyEv~Z<&O;dO)mBXZKInah>f1(ED=;{6SzRDEK!jM)x<}finUH zYz)vESCAJNWM$z3%nxqC7H)13S2u_~U^q@b=emb0D{#!}RL7uTD;UU68YJ^Oora%! z!iSR+*u@s`F!a)Ay`Eei;6OpCS#Sm-*KdWI*&lH@`jQ_f!2bu;1?w+qgo&7JzT@29SaL;3qTF zd$ar_ac54K`Hc>oPUJhkC*JA1albF?Hu8!{eB|9|Mt5c z{Fbx7Ujd)Kla&P&Y9>4|0ivXQ?W{htg5?gr1Gc7j;A*aBhi zEc#Q|ZFH>s+(D_bI;sy|(;XRvzL`2{-gkK9f zi9)V6K-@k_Z9qWg0?gbRp3waG3UZoq{dR6A$^v)MX26i&V+z+P;U{SPSpClfF@;AS z;C!$(2OtV~Qgt?X{B4YXj2>{x|4IP7r|)z8TSq_6KNvjV8dX^Q;gsuNspfWpAw-@~=w_niPq zDiDu(xq10GxP?VP=R5g+FoENSi8C~!QgrYVmgzHFae1<*aZXwvO>74{DlY# zB#=;7Af@_&9Rw(s6W9U@1KGkeU}tzr1iV{=oh*EyARrOTP(Cl{J`0J--obUof1ZyDk1v!ENz{Y=9kbicjv|L=LsszunP7RF~ zB5)z9@2W z1w`j&eZmRH_sr~6ppGuCUcj>CobJL^)YSt9fOtfcFF3 zKcIG}PT$7f8&JR#BydCi_ksSNUi^UY&qq#WdRD{#F2>(38vnZZ`yVBIj)K!10Q5t; zC*pv6`~T(O-vtjy?v$#N{(#VDeCDI+zms>)*?72|BKi%Uf3=YB<&$4^5*r{uov6u= zwKlvw1mswNiJTN+P6F0x`U0Xqlhpk)*58ZL|My;i4)8^%RG&+?Ku`}$U?l=9nq2|Y zw{Y@;hf{bcgeMySI-tV#v+M*c$$|0%d`W(qlX!w%?19q&hx)5d24p{Q?LEB|kRm)3 z|CXokMTP&Rl>gS{zh;SaHWp4!mOy$7Hz>IC2Mq2<4)wR5;D$n{F2f1Z2hxj^ti=k* z>w)MAr{W|Fa0Xk$%Mc)dHz{B)N8 zYC!Poe|X-%_e_y~m126!arB${8606g??rE22%efX1KpB5_&+(o0 zlcFPBD^IBhbn~QUYz?yX0rEr_4?y$+|y{uL0_iIe+jc<_ae6Hs&F{AW{xqx}m~ z9iX3+YB5k!1_8MdkVL>G4~+KRJb;B3JY@iSxA;*Mh9}v-YRPZ_KUw^4YbPaSH(;WG z`F*b~1L@cgsQ(V|)aB3vRQ^_};dA&`Gl8D~f1NC&h%GlkxWAs=^_yV0sCbdh%gZl7=dqp z#2=WeGf=X!tPYf;=5|2o8 z5~<;rCqsof$oaIEz^|NEBlA>+zu~*wfniFUtLE#ea?_ec2?xvPX6;P4j4xN&?rfI@ zDDQoJNj>{w`?6$MT7y64m3J&CLU*F3XGmqmkXKN~K5mY!6(ze|xV$QVz-OEI;wp>S z>&G{_dStw&-wQ zm#Cwjr5?L9+AD?gJ;8c-fTXKfzY^Q1jpNddxw#l5?+)AR2LzZf;SVmsA`M?*jr|Bp zbwwIJV+`mwh%N=UYiwVYLAJf#|BS4Vs{yH_eDGo<{WzcCru}U~lniu&_#Dya#nO05M@%SU8dPHmn1YORG&hn2&o$Vzz zSHA=W!nU1xRMP3TFo_L`DAOC2$*(1t4Vfk0!ZKh9QGQguMqe1y)ON*yE`9ts^=i@n zhn;%?{R;+~jzY9?kL+iPFFcm>;V<^Y_fmeFG*04NXv#>tpBVdvYoASjFlvzcjRqS? zC4I;@R*=a-Q_2vXO}1*#Qn+Vw7FzGzmMuHeSOcx1;m0x)dVjh9(}MV15KWII-K5S? z-cyU7mJ&Vb*I}2oZcjdVjFG9#5aRu2K$x@a%ePdwgBe#O&UNFb!dN>=eJ?-Ff*Vqa z+Hocf8gop)M(B~JSW#79yU|ILZuv+Ld8qixvrPz7O5GP4o5!4#ZQPvMH&+(yxR=qOE>&_<(FTHMh-RtTnPdq z{15OFLO}UX{E8X8#02#KiXc!fOQ4d=3IBY24D@mV3E@}o4a^ZnO2+vyMi>YPcESh< z*AP(u+uq@s08sh&umbKTfw|6o`aUQUFeu_jV`nItFu_s7(IwL{{pp8@hFw#aADej9 zhE73EEnS5lLX1Omp2r}(Xt(pEFE@-j4wy<@ro>vHpMKcqRNDS7kKqZGxUUge9PP4c z70a!(<0d>F)Q`yNZ2mB!N@4x9mqA>H2veL4lcAsSXPMYQ%Ly?8mnu@~ryk`$Pka#^ zi&X7K?tTs0j2)}M)0wngim^2 zH#3pvar2Q4`M~y4V^Atf+@*`pwhW&8n`h$&4TyC}PxWp@lgpwtbJ2gn*D4;nvzmF! z7m0f4lR!maG@80ebB5JwS^2Jg0PjT!=XT!#bL!8E;x1U)x3UCMokiJu59e;V=Pq65 z6%FHA;cyVf4NY%t@n7|1s>qCghpt{;Ymu$ck`u9@l*M+m9={@suV{fmzq+sG{4Ke9Nit- z33l{4D0O=LUaI+>xS6-_tzDI;sQK>%%(Ax+X%4^bq2OOhif*~ZG68-dC-j0L2TZiV zfLp-Kjf`F(Re-e+id!BbGBLwEF1cyygCsss9D%#8OE_sZT=qUtp(-GIt|#W%-JaP* z%Edx{B6nPfOO)5ln*5W%9Jw7=& z8c;xeXo#Vsj_(I-wAG$`BpOQnh|~kCT(L0iqu!5Z#-nN{10Rf%=CXOefB6WHFX*sU zX4akE>MgQ2T9CCwVl$dMarA|Bk z@XE!fH4Y+gmvgl4_#S_IvWubbUghQC;q#;n*8X5DN#a(L%cxjG+btwYBSAq6S`a?{ z6svpPfR|$)x_03l|IC0r>-sFeg`&yKy4mL$v(GIWqq^%J>$Zy-qmN?!Da+X%W1`(? zhiI}EWV>?}y|j+=d%k339bS*0T-)}!+rDPZUgdeO(5niDuWaax!}m46L^D1GpY;Z< z%-})lEq}RqMLw&+F#LDSomXR#YEvXSX`-NA^n)+JGX=qxwv;M?&yNkCRbIPhhu$eR z&#t?RVW2jkP}H)408YJXq6EtBEx??6viNk$P0*b)Wmwd{g7$9j{&s zt=^3Zr4EUB#oFTBFJC6<+j3+kl8)Ni3u*GDaPLm+rQNZ8kMO1#p}7%x-}rO#C71Fh zaYs?o(XDqr9&g66ig{nI5A$T+WfkOS*PN@!GMm6CF>{f_Yl-0yHhA+u)?k60HF&yS zpvLW9^@H)vjUWni~Si4tR|Ggw6a_#o%rnhL~?QS5abSx{0@%8m5<11bv?Vuj^W%r@Z z0Wi|h74;)%_B)0Cs6tWC*IXE(^WKhb%M$t3W17(sovFe#vz?2HIP7gJ{fcqof#ghk zJZiiC7G3ti>(pwV#d5cYTeLn6FB&5ZIXlXi*FJTt6Y#THt9$W8ktM$1AgX}(y{xKP zPE?wzm!Y52^~H*GwYi8o!6%!%CV93;J4VPa@=_BB0%YWwX1H;&DjGZgCZaq;~cBLIpUUEAAQ_y3RDOUE$*V ziZi)&kWH+cH#eo_)|<++Wh>A43w!vP0a5hg{0@db+ZPxb;b_$*pYz zbsjvYj!+wCT%cTd6S4*?P|tWzL2|?Vj)Q`tL9WeBI?)k9PXuqt03L65>E399S8P;j z=}Ln)$S@lbLv)b|7X_dm7Asv{h;0u;z%O~W%L0RltVpZPzpXlzE0B7BnZJu4V!MW2 zC`}?FaqQ;dv#H9vXahlZj(4kU+qurt=B-ap#uup38?KrN)-5FjEZ%UT2%e2tN}Rl~ zU_Q(`{2_I^^PBC;qrRDR$#0({`4IR@=|=pIOghFTSd^;n!0mJTmkPEHoZQn+el-n=|_5Nru{eYzC(fHxsXK8&4e$@h?wh ziF{z@6~^L@S9e)bU(j|gdUtUU)b+XRak^Rs=cR`o5T+ip&+O9?XjuFA=VowLZ}p4b zq`pCG#~1Cf+o=82CnkX2_l5L8y)E<3v1X&<&PRcq8DVpl+qN0Q#eUA|tM13dg!j2H zhMFiLk(3s?R9v-W<1?S}o@sG5NbhuQ41d_7FScYaO`=A)8%+P8vi?*0GvPkYZdB}K ziCCK6%P=o>Q5mUFby19G3+(JS7uA~g($J}@#xiO{LJw6V7{2P_*L!j}s~|`>s$f6Z zLBt{xBOS6ozU~;Z$T^wMz}=Xud!S=1IN?>*nkt`GZOWb^g;LYXGkWFOrAJpbtG!aM zcfthk-L0ja?I-P{rUMU7Z5?rXI%`|Elu&Ez>#&=D8@&2%leoF0G_Xc!+9aK{dFDBR zXht~BvWt_N)sr+ffy8kIEd~m5-SBh}-YA6^xK2T#+PE>i-m5qM6Q#bsnHh5m>qtXJ z^_Crpp2y9?ZdZ36wy%Cv+P;!y$yc5rtwtQ~x^_b*Id}B`xc$M&tYEaQ5#!+lH zsXO=h!mn(W=0eE1T-g`Mm;Zw`_}N_98tnOFfo|sP0c^7bHlP8U7oAR0SvpQmw(qO= zAMbxZiPOfy!`sQ;#qn&O-NhDZG|lRC#|EeljA0=lDE{|(HUubfSOYt3+_--JcQ(Jy z(^qv}5X6(vZ?tYQmN@4`JEDBOI8hwg00Fo-TZuy%Oh|IHE-I_VB{@hm z(yG;U*R{zf(eTDxNAMI6CdW{Is&RP{zQ#x}c>%*)hmr2V_jUd|j%umQ{S0>ZAch5r zu(VBw^bB=_M_pzH7BASkgDtRcB^rLwu5M|RfvFeEyFb29c@uBLS>M>jNYBkyZp$?% z)o#-v_XCdHk{)I(^&#oU(M$ZFF}Z>s-o}s?c^M*4dxKIwV(Ijlr$9tu35+?H}A`#zIjqYwD(bL_aOT2`*6}vm%0;o zF#>rcpNxYI$8d_Exs>2p>?vuGT@qe}pA%`m9dpV;4yiRd^YCk5wqX>lLT-st^RyZw zcbZzKZ9&qjd8s3a5^rzoQ0;?+kkpRb`?B}2xyFuDz+s65Lnz&_uW8J0^t;W>r`Uw& z2|4e{$0xL#1~}!HysF51*T6wdwDQ*8E>rnH<)dTt;0WGLdq&+`9x3^&ihFW~Qb)lr zIkwakWQE`MPTmkWs0vnD<+-B)nOUrntJ&|lx4e;A(p4hT}MV~N)djo zvW_$DMcSvVs<_s#BDuR!#9eogK;8ZO$ydaK_U|J>ZRcsX*&ZH+e_MMU+s+QfDXb89 zRVq_39~qTLW9u8B@3KoaSdPzita9gS9eXo-V0Y^MswL`8{+h>e^YQBejGHgEuU3uH zaCfE!bn&kBxILgerXC96e1W}I!nN>ZRq$E)vH!G{cZAX|nMjUn1j^UPMVkffP-~e_ zw$8jVbfEQJoWpO0hcmWIQyaMhn`O80>Y+zCm(%B-ua^lfU`*Giac@R)Dj1LiTo|sI zG(h(c2BHW@hd!}%IceCF7z?e;tFesLLah6=@c$rSn?!{+erfYf^9V@zC9^s@> zv@5)>4<-_^XP(xUwdlHBM3`q{h=(ECaw#R6?h;tiM#kIaHW8nS4f@E@+q>=d+Nez- zaya%hLP~79dOTzskhibZNG5$$b#p!g|8o1?QH6`_4U_YzkKcb zbymaDc3S~Sz{f&>cKyHiwLksXFOOyhzfl3@vVcG=e9T;J%hEP^ z(JR-D&@0d@Ko|@c!AOznQBustP$Fd;e!l@>0U^jG2+JiP%Ox;)$}8Z>Gvdh;V?4pA zXfSCoIaBmNiefdq@rvRO?F9sc8KCL?5odfBI@FBk1oH9mN$tZlLHt@fH(vPeVU&K~ zZHB0Km&>_zEDJ*oq}X-CRUyu$BA#G!`ER?Kl+0+|Tb+&T;wx3%Uy<*Xcjk0dc3?P5 zPjf+)e5iD=J-}9PlRXvtokl(wg8MTgo^}N2TA5l6MVUl3-6OS*vDTyUb&k&_h|pRj z-F%M5Ur8bVxX8P)oSn3BKVC1n$jkn{F6(WR-5S3uUUr(6y9X8i-uTs_>{v@P z3c+GFhvb~Amrz`Bj6y92G)1GCJ99l&ebdxMAkQ@V1?8roeH{!kh zLd$@#PGcR$$UBGw7kJ;++BN@0IGI=CT^IqutOLyq0r|g;;s1kP{SXd^E5zQ`-o?V{ z_!t-mkdfnwjHHg*qj|k~^7kF;U}!M(WKIs#;9FJxSLLi(lvo*$o0x>{Rixjo`LEZC zMmF4EAoc52WmjR>yvDTnjdq5mKZ`Y+(+M4J#BLxsHqNfS-h2g=&Tkf;xShow!vQn93- zuJaB1~ojbw(pOZ+BGe~^7%O-e*6Tr_eW^_Tr$1dJ&8t7uFHVE3Cq zGx+c8lK(6x_^oRw@DzX@+>X4z*DdAaDsbAkvE+7dgpKrVpvK&|;CT6pN2I(`@Wy_$v~Z-^GMgEhwEi)hL%cKiCfg?X{nB{m$(m5@&#xX|A(}kQDAso_a{Fp-%yM1 z&f${mBfjBuStE$PeQ^?bb61E}t7d!k(|%j%wk)ATXoQb)=6Vapr5E1Q1S$tIDT(MM z6zBvjIsT(w-lQGw2shnENZB~t5U#mJgH>Jd-2@X^t?x-8Ulg!^h->V0XH8DACL2i& z$IG+)UD6S9hu!uLD+8k`qoSGJV#6WP4j{P zKMFwmqyE#C@!=*`a;4d|BZYN&8rsA%ndnE4zFuO9Jvch@WA z%Gj8o-b1I`1qnP#&v>7ZbX_>(li<33ZT%xy2mq@Ev_I;T&H+9nQotwu!o4)V^aFX& zMoT6fIa(Rw^H%`!?Uy^4DxQQW2Lz}co&cX)Icagu=GdG zZo~;7?Cw_Vn;GRXadzX&`Z4m7h*>lxYG}(FK~@|GO#uR2A&* zSMa%^4Ai5G-e?u3$RFDxtf1Gx?Okq7Fp-}5+_+m6ZXf){P(=MbY8M{;rI8$Tjy4Es zL>`7tC~C>Kc(oo~lENX*%_5JwFhS}D<1^Dk1|&xM#boptm=-tSV+{VJ`T)WK!#Dk% z&y`{mDqKQR+JbgIl1=7J#g2-&`kw(>e(+zxfQtGzOmdVjHEc+C_3bCo(wZ0j{ zT#XCZL>{`f?{BA!+$vK4y7h2aKL?3DQ2I$L`@`g@$Zy}|u6IJQ^Y4qb-^AQ7zxa@; z{A~{MCy{H2@AwTSS|XAjp?e44^Ost%yBcjd7L@uyhj zeDK1@wVg;NvBti1yiPji5xSPswmpR`2fMlKT1)T0ZjNsA;R7Ov`bF<$pY4HXA84Ik zf6Hwoet}hOd>PbXN@db^H?M#0qrznS!OhO+3-8Pc*F7*h$%jg{1oBwp?)suPr(yUg zH=QYFz`1`YH9>O`a0Fri_ZELrwf@5WPhI-SKK=CELo8E7-iPQk1hS8c{O)+xk1-nX zN`%G-)s*q5r0CgSdO76Z{OK_3QYGhupq$6=)jm{J`d%Kf*S{CKr$%_mZa+FI#fFCQ zIobGB{Gx~0=;Cq+<2!eh_t;2YWbDe-QqF4vNFvC3W#%of*YNE^<8DZ`o5#utE=t+k zC*!bKb3e|jhzA5PEAtT1)x9#v$2_=uZH)Wrs-|bhD$}u*+danO7u!=DB~G}nW`dP7P-nrXXAncW{+?0;;rX#fz%U}0%=nzIXfMx0AJ6uO0TvdiNESM7_t}Qv3RVx zggs&rXqavGi~MR64nxaPR7X)X1cX3fkB#1+TnKz8pZ7cafNY-_IJ-^?5ga`>C2c>UV&+G|x)-AYf*;oRaCWLx+hwsX z^@&K?W**6DOO{NQu?kFkUeCBgOgJ|dEHwO4u&rCvp81O9+LgDdS_Z-oX2{n-X1kOE zdRneh-8WrGa`s!do(sNY;zT2<3Tm3gFh0al3Atxfxs?7vZ`lF4tA`gacU*+u*nm3cDWxJ;p%WL7>Rmv_sx3gYpwogNPV<@=3!x8 z-()9CNMo<}R~{&4VXCLxt*=v? z&-HY5^K+rXL1?Wu=k-$f`mojuf;Nw{A4LBSyZy+yyU*a-H}mI%I&UD#rXw; z4~j$FWEMgWijr68ExdK6y5<7~Bf0XR>W3AIB1U|SiuJjV z5=qmPt}XFly(Z*v9~kl_)0e!YRs3K$U!Gq5PAg!s8|JFmPbEPHJGrxa;vmyu|h_K6+#FmF$^7*()zx z0@yVTH{G`)F+~Om@^f$ZwiyLl)67-d;|R%(p-v_A$0&RdIiQbWx&>yAtjGRP-t|7Q z^U|XmI<($q^!SbekBb&&i_nofB~gsl1=Ib)@{J%=5AHwFRiC0%C?GJoG}e()cgH!2 zX@H8qOW(nisfpAuT2ZECukd2rXAr?ufw`<5iI8to#;dvrp!}j9zh@D3Yi{oYb27h2 zkSSzXac$K*5mr*dwFBSEr|I^YdIeiSIEEp9R@!v{hkJ8Ra4Y}KQWvPBr z!HQz)@OMPM2en$fef2e@@Co9KF>XinYrElnw@Rf)RWGc0KbeqnF-F69Of&bo-am=- z9v8YTPvq4T?m27NcT_pt=JkQg?nS%_K}qG?q{kY{1uri7m$>f;?A>)eTB~(zf3o6s zZ>E~GN**n%3GEe>ls`w$Kc28nff?3<{p3#PU6kp}Mdpp0xC@I2Ht8{s7Lstf=a@-j zaVxWWau*{HU3gdJI=6N}SA4`XDHc=FI%Mm8(=*l8m$_3{A%&h?CNKjvGKuNgQM4lC!I`xjrZB_ljyojLaGZ;dzOG}B7Y z=X23*Un;O$iC^Kqm-Q+_1eA8 zh07fgjq%a}XiXB0GzTP@@|Mvm^MpJzlkA)q(W6}SuRI&xK}$gOCGIlKTV(So)~0z@xvT4|PM@;D zxooc(^oYXdt6P<)LRvW{E9!ETzo;CJv_Dl{+|=9JpcV+u0xb3tinmuDl0Vwrc#`Yvj6WK~+~QP5 z5yTj~D<`(+(y~EZH#bVhZ$j5jc4Rr=|DmGcaMQ@{vx+CiRb0V^UTUF)uwK&Q*#$T1i$ySn9y?KF$SS`hn?4BP%1vt z^jM00a=VS(luJ`?Ol>=EQnzPSCpfy8dKcxEv+(?3#8gD-ot;>v+fMT9dzdMc{ULTW zA#=q|?7EL(R>#kMg$zdhDwTvY_FgJ*$;So;%3PlC3!I6`JwCI-Jy|btIBiD*xq3U$ z{%Fo(1MKpL{U~0Z)GR4uRB_rtKt(LGO)C|jSnz%*^2>Wjd6zWVR>eMRYwGy510uL^>{;TlOL0$wm(jr%O{O^4xMaz+mD{*@BC$AfzVy z)Yit&k3uKWkWg^sjUUmE6Xu5H-B~{**6!`)M4cEAzHjw#&hM%9iZH1Xiajj@cUR!A zybaC)Muo#jA~649pqc&23fMUgey&7ZNn-vL^aRoRuio^s*8Evi{WgL{uz_sHdMk&}R_jhBc-3e-_A3yK9QWp97WX zRGMcot~^EtI9aV@36efKvzT+nW;dKCTnP|8Q3`k!>A&8^`Ol>fI}3>QnL4TVEKn`d zx`~*#74w|Hj{(^jIj`$bD=hg?>@z`FVoYy?Q`r3BTb;1M`C-~HNV%Pgga+b6l5BEx zgfp58&!Z5!AEh5ql&NsoaPJ}(p>*N{VqKr6Oyd|a^d=@gF_MlFzs=w|NnUDw!?1A_S zPN`*&+$+%}%GA3T%rFw4g%xGJqpF!SM8hmQg0=lFg|1$5wM-$0e$cfC<8j50=^j~oiS=E-UD%7r-Q?TC?N`UN$tGNh`dO+uIs4KE~=(mH;t*{4UxGs{4QKN zH(VIuponIVb=5Xt^rHcF8i8ndmp4=G^;S(R2qB@emHYDb8FwW~YwA`$flCBxBGp)Q zK8v&{e3Hiz{w>yzh-HsC^jdJ#t0U18uSr){xy7dWApc17u6DJcAdV%Sdh2bEfwC;Y z_v}G2oK%`o^F1vN-Y)hX*Kb%gmEpX^stZW=@G}X^`Y0mGp8e=I_o){ms^K_IGx}9f!!_IUOZ=S|+){BG78GEao=qyK z=q*Wi&o^)LG!X{;$h~?6-7QpiTdeAa37#Q)x9YD<=QH$Hy^ZllPW-gGeeebI^@G(< z%L<2**O!vMvxMD#X(u;J{B+3VN9He*J4)a;}hbl>yEAbfe#H9O=gtT-ZQX zPKZZ!;GSooPr~bvRU3@bFV?X+v(;Nf?1cdztTpJZ%vCZnaimFEZ7Jff1Lp9MRm4Gi zdly7`ACd{VhhnR0h}eWoFggJxy@;It@!6^fM8%V9_s->b1U61C#0Uu=4Ib>N+k1B{ zg(G~qMG(YznsU?zUYaQcyTn%TZ9xX7oe)>ct<0NjHk{c^O&=axU0Th|)LcxElcq(L z=`h2*exaj>#YQ#um3CmoPJImtHG$HwP<>NA;w#BwvQ}R1PgCpC!c%M^YyJGnxai*u zbbI`yF>_-ESV!t?mJ2N7W}6GqTU8G31{Qmk#Fa!-$|g4@nQ*VL=hvz#4H}r#J-VVY z=ryi*#IAuJs(dRo@?nJ9Lnq=@>h2nntzpZf=I1Co+0lXtvQgd2p2XSse6qKd_!5+g zo%%~3mEZ|rzlqYG^s`w^h~&A#%6?HjM3j75FImJo$Dr)_#YitpcZ?BF-G1Y0@>r1< zLlYf7AD*XUXP|x?w$Ih$DyhM5#@pXVCtt|UBhA=K36pH*Nb^$gs&u&a)xF%*mg&uA z!E(pA`^NgFe19eRC6l}g_NFIR`rCcOR>*hAwfYQe@~CYz<3|bX{10C^S!Q*TyoejQ z^={~eL<&|xzuv3;u`EwQV{H*X9hBNNC)ZaLrqZtk*$EigR2L7V+j5`F@;g{&r6MPD zHR4@Q+IHcVGI%q*aU3|2^BPtzari1`u^Z%cSDkt&E@-Ye!Fo+^|Q- z8!wg{lN#x*^k=*`S1vr>-!-`@?(NAc^}bBjB?I@xTKkUJ+dL*N9+P(~hn0eY&Nkr` zd|w!<>#~8Z&e!BZ^11Z&D-&k-M0gR;hD~@bAxK7g{Q(d*)d1zz`IAuyc(nCbHg$5J z-XpFao|n7{az@BHja9ZAo=CUM%oE4`zwX3rN&;MG0Q zUuGHRY4?8hEfk!c=e*cqVNZ@|fqHFL^dbmt0U;(KM=Ix{%-u<>!{LUhgBupPlm~cz znL_EVuvC*J`qqR`g&oN+KzHK{!IhTcS0kovt0huMAaO6Ks1aA2P3gBMFRc<#*7L2Z zZ^wme!f13hZkPa1VBB|}egbT0tqs{Ob!cqz^$!>z|3y+c=CM)|$|x`V#uva5g2taD z$;swd?Qj9{OyeRZ$#aq zM%f>fnV-1+bpK|fK-eJ1D$RhbL(f=xhb2chTX)8*=5?h$PNLx0fg6oJ+x(;yB1=Jm zq3uVVbV`$P>1tgoRr~A(1B7BXm9nSU-e)uM+y`%fDSSsPLEbqpQ^m($nHccSjy=p_ zGr0uytfOI3mgykvka6^IVjT<637;*I>5SpkK#@_L4bfhP$v^vwJ6B_lCPrgx`TVXo zizDsW5m&v!ihZl}X1M1^6f!PuoO?1`I9)zCTVk>Iz+!0?Tx0R>MOdD`XqS~dV)4G#62E>jM zq&vkB38~54U67&8{g(Z3Y+uV8`3G%IwX(H^TU*;AT-%A+sB6KtyZCS9HQDD4^Q#aa zJCyPaD|j5)-B_yjQ%~>j0yQUCi#`*gs!8AQr^GgwnTfIPPAuODGTdk*+3yzFKzh0; znSbfMpPx;d4c1}71q$)_o`e`Q*PFs$WN&%E3Ta+*ZSBc_La2=8^i6d(j41rsAl&r3MmAQvr6N{l63%mtY4Bzcw zQ~m()p1bp|QmNDh_5r|GNPWuMN@~}7d(T-f2EwrtmALyZ zutygGcqR_GV*$AD#_sYhhTve`HSN^#zHQHI_?3Ot=9;!Ot8hii?F3_xj_Q%xh?|6Pn z@jRk)yZGRcqQ^|%qytbof%ZrJ?CDP#{z?zvy2KI3gW1MS6uNs9MMo)OSd<~_uBGw( zg)*8_1TMMLR=JP#w_V1(A$PC0o$_~m!8(_~M!B~{1gTKQYd4&-M`8&}(7l<6gPBT= zOw{y*-G>X;z8F*XImHU$7(Kq_Y2%C${k*8CPw3^eHlEwfB*tLL3%QudFY|Ibvyw`# z@36JEew~WhC%!zMgtd=r7xPdIi38z z;}24P%IK6Ays%xF1CvoBFc#`(#ZpzO_+qh{zipl*p1m z!GZT3_>G(1ip0TmrDP^*b&&Z7R+FDu^e}-rAjw^+Rd9Np_vjYE~d%kLn%S#dT2(8T`{`Iu={)daIr3a70JJ^O%z^gDWqJzyr%bh(IavTl zsRKC5io;iCVX<0gWVmAM`vGKurOpMEZZyq5d#azF+-7%HUyuF5jn>UeX(lyvoU*Zq@ym_Lvp3q9Zxmpm z+!wM%RVjEAr?_fT)fwu8H58s^7sN3j%v9?F{Fn}_?WOEifd>APvi-GZZ#M7~E_|!x zb<0H0O!&ZItp_Ut|+H`rE8}AXZ%K&rwWi=`% zncW?={Bf5E?K^z^>W!9L9qK|lGq$K=P^eYWSK>?jD*m9Xc5z1ngf#JtdxM*RM7Q0Ml=`5^sCugV-h;e{9L-uNcAs0% zJnar=$Ltc8B_+TPInea~Xx#hmzxcmv3y_>&KvV@X8J!4CRv-*VYHBg}=`(lhGjl3k z?bVw<8<63^=m$XIRB$y0n)&~Q8lM6?BQ`)k{srICS%9K!TL!(@FA1XnaD>2hHo*HI z_YwkT@I8O<-$wPc0De#!c0#0c3=e!?uKaH1JX^0kq9DCX>lg!v3ri?TVs&07m7+A( z1+J$@yMAmG{h@KCOFnMmGCP%sF--ib4~wkK@{o2&Zgm?#+{+dnLy%yW3@&AMV*To3 z*GxJl#cwigMQ9ms8@bH~lE`Rr79DMEQ_Wo!8sOFx*gR4nL z*ypWGx=(rJ7Qg})z=qzRw6fD@5`Lyma9?j4CrSX{o9uVrQjzFAztCZSqWhd#5gvx! zGx0?1(CjV03CivaMK$OPg0jzXlf05sV~i3)FtTI`_WH7j35jQ3rfyPhbO(a1npdls zl`Dx<3*?!!K6zi?lrdlnm@L6;Fms$oJup;#L2K2sWBVeYgOKqJO{X2MP+q>U7f0Af z0{ucKzcagM;QIRT4HhQ+P80_~z#m-~oFm|;x|+t-;r9*3ju$Gegc8 zn=TqM|Dkxjrxa$&%B#HzG5<6^;=q@n(*Ql*4bwm7hn$C4U^OkM#6|I ze-cc`&yjiuq?wria5IuMP2$Rdj9uN^Hv?#W0$KAY2UFLS7chucsgoLe2pJzs_?2Cv z2qxuute{e2E3CTwx#LU?0M0{U$jqQDzyo}f<{#Z_{GEp%LI1>`M5_;LUyEYV9Mx8d zW6_LSDk|44(wUD^AlB80($(mD$)&8z+^wX`&8ecvtbVos>MJ(QE_OYoZZ%a^4n+4B zquAuX1kbm%B+K#uavh-k(R*p<(EpU;X{`9`EWS@;37Ciee=-kH`nh@FvPT-NlF9^i z0*^n|0!yoF|3AzT{)Eu42ZrFE&iuAX*7v6%Rhun~y4(m#2LR!SOk%LMIt9s_S4xAOb03B% zv_BDOeB9_<_Z37~r_eBL4yN${J511-jM?O^rL4qm8R}eb#3RnMV;F9W#$6?StXs5V zO4*j@Z;7nZT4TD9w)f-mTqFh4d(F|hfBdS;z-SA@+R!o_SZ6+V!cicd* z8rQ92;NaND^9&ITka@(Su*pnC&$#F~W1wTi0s&nW5Fxfqw!`U3d@j9_&N$>Sbld5i1*Ox$@^_VLk~ zhyiG-^06Lf;>=Y+GUWV&EI~e;?>l6uXj_0niTcoD z%oEJ7@(p>k>>vkkj+Z@lu{5$&SMo?SW-J!nD*aeF)XHeS_=ur>S>tadXgaEP*m+~F zr^!FVuVK}=l6jAYc&&l1O}&>njZ+Qvp@Q1CY#P&-wg%YQZnU`0InA@Q*yW#4GN;?tw3;^es$EiK90Wl3CXx5E-i#TmovY~nCfaI2TGXg80Z zoAVr(+pzh&dhmAmwLGtLSG1;Yky=d(x0t{G6#Gu_G{*5DjjyO+XC#z*PMiI`F?y|t zSlJ!zggZ(oq5{IhyqRxC7b>pChRl%G9xpgi?O$v*)>ifs;_68QqZuy39$X+UMZ4LQ zwqc7vFo(FJF%)vILigZW#Bmsj;0tILZj*e6NW4|FU0NmCGU?0e&|Wc{1k=cBV#0*a z>A1>bGc{wBtxHRh2MqDIXS;aQjckI1cZl9ZT_(ZNatRjOyRFvgxJHgqrm zN8b@9@O9?t#vLX{iIj=YDFg>;6nfvuCo=mJHtQ*9_AzNLG57;X4 z`7+dNGX*xy_FBtcs|gRa8f&(YDIqs4@GbCUQfV0nh(8dN3=ctlL|rEwBMtc=p+>Cp zlq!L|A-&gpT23QbO^T_W++a=$cmHW+(mSaOS87nxCbfGd>B1??LS}>wsVHzSCvQ&h znCLR1U(XDMsP)>DwUOU%nPAC4YL_=SDuH5LY}QaHs~N8!#u_zVWMIh{)*#aCuSb-I zxaLvP&aH4;(+NpV_X*rLz0g5d!rNH%c`$^Rw)Y(#%ZTs0LLOXt^2Y`VdHQx*Lb)$n z%38CtQFA0U<**G{SoojLI@)~}m%^9M{w$HZ@yv!kTJdZABgSiQ_z&l=Rm&eIJcCI# zvyN&hbFJK2+7bPg$dK^)pL?Vo_TT57C%**sn;&L^Kg|w*Kmu4aoc?&z`A;Wa_2%u;dOj$^R`d2ROc8>o;vJE#L{y<@pl9YF$<(4%WVY?LkfM z%KxvovjD3)i}v=RrKD53JC*KIQo1_?q(NyxQc6JSlgL*YA)GjfQz z_s+sDLPD?C4Nt@Gp7Wr3*nz#oy{!qqXb1>OJulX>xXDB2-!icnj0# zfV0&gitYiMAJiQ(@3#O=-B_u|m8W66mJ^e#3{bG%p9o*(AAO8F(8Er(M#+0`<1yDm zG+i4aI<@E|P<5#F#NM}bPIaI^M%+=5o^Ac>VNoeKmKfg-z`x#vO+b-o^_5)CXkqah zJZsPc=hzIEJ9kXB+QK(X$znXE7?yEgIbm zl%{d^s@BX>be^*!|A^}ttA3ltBR3~^pG=Bw_8k8^-rF7}CCx*wI>jm;XCE{yF(cXV zSKgjhSC46wD(w5i_!#r4eN5`f4c5}Y*16Rr7PZtj{OXLtH4AqZa|eaFL4}fyQ_Pmk ztfx*l)9EzYWEa5@BXy@rwq-HL!-ZGch?sDMGERiyGy;tZ$B3| zsF9<4iOuaVqvN?t1)>W+mV?@K6Wa=e!G%!Z5JOhX|eag9@WDAykeNowP<;Kf) z=kJ)sYPdb+duCaX@;q9BL>8hnqN>hc!?p2U%AFk>)7sp?ozggdUHkFx_HOp$P<%AF z>@$|S(5*QmZ(u_*0vq?hC*tXikN=R95LZhz)E-s6g<_>H>9(s|4{s=m4CgW$GeD_JTE8VZBW zqgJ!7j~D<7bV;hWLTds=^Z>D=XZV;di}f0dDlMvlv(+q2Yis(H2t#rrVzFI*GAz6a zrMmDz{uPO2Tp{xOpQtm2U}y&9gxI{9$iu>EY|>EB$~>&Fr>S?zrY$J4?LQiG31v!C z;eL+gmCp;m!_Qzt0j9ycg%AG{JM&EfL?xz9>#S1RzCi86qyQt|0A+JF;f&io`$g74 zcha6lua>E*)gzLu>Ii&VHVNqcp{cvn2u!nZORU7cnCGg;&SGVRg!I+zNXIxFPLhvAnIoyoi(Xw22L{u)icT zw|#&phS7)hbIKq$C~n++6f}YoqicneGgF#^sTj`rl*e8bVjXn=t3PuN{forYAlUez zW?l%FG2>BnS)~KpqtDKFnYF<6tKcLGKHkbHR5RrcvYp${e%%pNJumXIH!%|N4r+b5 z(L5$$S~Lf^m3f{JWRF>M4cj4A+lxDp@znKT(8Xyj&}886#>P~}RAsuU85B-CI*Y?T zEwRg@3z|3K@cF0rMq41Vjx~()FQeu}KD>oj_tFGJLJy7A4uCJLEYv7AA=00%Y zl8LKBmqWJ8?&`N&*vY+yoA|_MvXUl2sTd+{#Zld!7#y=Y(%qN+6u;Cs);V^N(NUVC;iC;8($GIDN9WIKBaWyoW7`fA`Gq=eplX1y2RPzb>~>{}r@mosPHWAR92 zZ2@PTz2;*QTaZ)e#D=+39#BSWQNK*%jn$Y_F5be?loEwGzdO!e^-8zD`*h4>yRC(4 zY59Do`R@;P*Q6=WtVGziE!fhn7pXr;A}c$vBi@s&nWGu>4x+|hh;3pfmq~9S_`0GD zz`@*)3*#?%aY|@0dvJ2c{2?2;PT0Fw#6l&B9o~4^_p6mPZ(X= z7Rz4E9n0Gz9@)Dr^*L!GjIddQmu7Zq25#|wn%t3Iw{8iP;ti~Yq*9Rwh%cO|WVc~s` z&eU=>kMX0%(X2msG6$C4v*GZyTm4E;T?H@880gW2h4+T}jBzirsm;b;PfIpIGKWkl zB5Mdr?z4FB6W&1j7e{GoPZAR27ff|XC{S{}KTsO*FcF(&q~RPe$60?GXy4(Ruc0i9s(<5}M|RAytXI2B9l{7XN$;4}UKg}T=_|vs3bU7YHkcq7!_V-emfRIm z%wyk>R7cumDD7JOXGpyd0X>^{hF|x6IdV2ycRlSFF{%jQj*L-``2l+U_^Q!^e zA7Qfpe2?j8f{VZAKv!4G8!>WL6HLhMGp`PBQwFrK`NQn{jlg82Aif-eWl=&C?jXBg zy!ye^+(a&Xi!Y7?QYdNk{R5W=WT6YCjGuSTu-e6I?bBsxx(Eg6JiLj=B}^bv`IMGD zPz5+s@$`g+B;K-!1vEef9Un9|W+C+}=2Jbao`>cfAkV_EY{bw+v8cwst(PM73*$YEhx53z*3;gE(tClFA+f4QkGB}um?=fk z1SgE^x_j`x3s?}BM1;muhzHI&EWOR=Erc+ch@OC-vp^!1WDG_c7Z~z_1hcg=4$v;h zWZj6)B*x#D_KIG8Lf&fWfCJ}l*_V`k(jUytyfz;Ew(4Pf_LfiI)GGt>JPnO7yZmz0 z7+P>X!Qm&tJE_x|8hKTjMrb|5EynkpV{e63J!yF^H9zxqXW7<&&cD7}ypx-!SGw-h zabC;Udo4Sp?_LpB>?&Q3u&^^3^yf``j%Zh}<)uEGWA>SodZK`yGfBMWd%JB5i3Q>- zM%^5V7>8Y%`$?Va_ageMn9;?bxtA6l1eS#JCn!x6mbs^Vr$RZ~&#oUjb+v2?$k;9=BK zvYpCqkHEME*%M*lH@BP;PBs;*g3z%zVO}EKM6RSLIpxRTW7H4n2u^NAP2`NL38mQh z;yy#7({?O)sJA&hfu(M$v3T{-;Uf`#ERr17EgTjkAz9iTH_{iDYDGe#W}<84>RXh^ z9$=-e=8S?Z4Ec6A^m&@<>iL+1^>C4Jkvo!;*0a0qwZtM7UxLGHV!}!TrAsE(S0{|e z;$KsH!llBcRu*!SZyUndn=HMOdvEsjs|qm^4h_#Y2F1efAXfwtfy*ZJ&RmBB;P&c1 z3;^(BWBs3Q^LIRKDSaUfgA#G|DqiK2y^w{Fw%B!K5tc!0vmX#Be zrX7K`FqfFlMFdD-da~EgOVQ{*YZ2B&j?WeLv7ru8yO)Fy$AylJ0C$?Ao};)F%H#}J zQ1nQDFe^67rQ{yZ1`<3K`4dfOx7$bbRE-s$Ro$+yI@X!`>I=aRgsZ;mEBP4NKQXPS zktm2PeNxe5SwJl`9>qbiV&-VgC>T0c;CLE+$d5~Zv z)MGcmMlg%kv!TRFe{`2?JQC+=QNRiDZOr4oXcG!v=I1Gm?#bPbi3Z;Tw)*K~Q0q2( zM%?(mD-zL~o*tt%KshHd11?ogv{NDQ+zgmbO`b3W2q*e$EEIAjsap3RqEhE0Qrs_QYw-NT|u_1p94dbv#z zBLyA<)8dGoyqM=hXIGA|oAHEZy_L(4gj<8anZ3>ODdEW~7uvXc=~m1Rp@T0tMzH(z z`!kSO2o+#Qzh-UHLI|8hStI_~#Q(?1J}yt9E^Y7qweF4j<3<8d$L8CM#@_7E<_cb% z{m21d%hEDtIwJ?z0A3jp!|~$9X~?;=k8*VFgyR&lxXva|iqmmwSqXX}Z0n<#+Va#HVRu1IZ-Kp>@VYM^PqUz~=`eke-VHCwsc~!Q z1I02ef@OmZ7X^QCimGzTBf~7JR64BHS*_^sE)_I@A|7laFy4|PMBKivZ5q*}8V-kC zq)RY94v-EXDhc-RX*jV@CmQyL!)8&u^;k8+;$mr3vq`W#VMYbBzJkt#-p>9Bd_LF1NRFQtd=d zDUNQ!B^q5t%3H7dW;Q(@J1|f9KLcKFi86?(KaG}p{rrHDc85N#` zW3ai$27SjmpL+NK`@F)EBD9_#`}e?jzaJ4gzuD(q-Ll)H zE(p8H>3Xbo!-J0DgAqwB5~LK}1^H!&O=l-E6?oizL;aivM1r1aCj%>aIt)z(JAy+} zEH?08@gBs!R)T)fpw>c$DA?8jY3$j=D~^LA503+d(rn_m=#omz!&If4!jgWV2#E92 z9Kh(&Cx-3ndq&vC(kja0r+}9zq2i@RwP|Ik+CMsC$0k02O_ND3cC^< z2+-=XGE`$==H<|VuQ?*rGs_4O_#$aUrxb$u2++8idGQ4c$54CcsRBe76)W?z=KV^| z^KEmuu7Pm}()!aXEM$Awom1HHv9p5&W zgQJT9QJa6DaPKvlqPNcjUV>aa{6LzL3=52|dyn$hZ$t0g4W@90d{$OJes{jDbllNB zA;MxtL2B050OwBSql`t|kf0%2@LI1rw!X<~En{Bo0OW@cS+civ`e%npc+ApCVY*n4 zF&&8G`c2<0Zmp!1;ah&r;H^KJHI7I12+`hear2~AIDUvX5f9JDEX*{#~;3&XUvuRrZY+v7%sZ{ z{a%h_MOX6p)1(>nDw(0{VA=aO_hZPTQoGLJ#s|J!)Xa#-$6{VR?-65_O~2r$>|^cb+}jm^!n3H7eRofhf?Lx66{M zCf&^RMj-7Q*r~TxI<88X{2f-S)d`l_Qx3w~65qC1{~`sIATUwCwdm3#L(fLf+EHp# zT+JS-(mFnVI**=o9MtlA9e7#_m_|yWQHr|pZ-RZJ-Vk%$(R}G^41tU$u`)_7;xGD+ zpOZbPu`{aC!H;B5T){Wz1R3$=0#d4A?jy~x5fOIDCevV<^v>R}FZQbQ(jNEqn(SI# zSp_R0s9_!h9s~H;0mR3SZq8gBtXV?6CD0@~2)V1YlEKOEzv9|Q8SI;Ym7)=N!)mi5 zRNxll7Q2UhNc&1btT@W^$Y)P84d2{f*;!db-6uAaw4BEAC|w!j{T2gJWo$(PPkT^C zLLe)wcoY?Ia)qo*l7O}RWllN?ZyrF;SS0?anA*c*|ByvDXRQ)8in$lT$_FQMBzGHG zrz|Ula}cF_)}bzw!%|JmK zCVg}ey`~fW8y#65=b?_Zb(|9`L-3Bzo92?uBYbtl7p>Khi$^AncEoON$m_T_!bDH*>~~awJGbiWbbJ%$Gp3sx6oqmKz(;D&%OEehiz{ zL;xjOz&3O&{!xFrYU82B?Qm7=%+CWpg+lkmm+bID1niJwjtQb^RFfpyV(!n~K`e%G z6^GCzKn|VHR6>d}aa(Ej*%(_Cd8_x%VU1wuNGZeRn7HmC@0g-!F1yxFi}ltBU7VEs6teb8GnkXSM(^> zRxgM!qWyqCLVtVLMIQe%Z*>e%*+7#wqK^x;f}Equ8-{bNUBF2oMDBCRcu<#T-S^WT z+8*wT<%u#)1Z&R4a7S#DL5eSVo7}r)o+tAHuLB0#pVRIB*d^o^c<-$)(k+ z*dSQVF4fO1J3I2?y1H?DFE`J2e>rXj93s%d(>DnPI%?{(ZykkqIPwnBzd%DR$~KTw zP@JECB}?__R&2J~e;HAsF0z*0WEj0dcG`I; zf|RO2K}#0L8uF!%diXm7#-!AnhtqDJTAvqntKeJeCB$9BTkqp|FL%?6Am1rVp?kT% zI6T=;%9=|RzO=#AH^e*-8Subpzb5ytg^~Gp!&NZ9HI`QI%s^>YBDf$_4zRbr!0${+ z%}Rz(&M!#DN(Z1mCl@ppG;YEgsN8WVL|WW@`ilE)3j|RjWQ>_qt0~qeRjDz>CR>;& zu3K9fBGQERqTL=N`pe=@Xg%%egYkj!d*V}H{SmUf=za2VJ2{nDn>c8MrpWcwRs0`Q ziR_Wu#O@MptO<=^itZ=GcR5EORn~&NAmzJPIwUiRrVb+(iI~f8R?C>TyC$sLrT323 ze>m16DZ^rR-7#TLV5HXqjnWds%=V$=z^cc=!^}#R+m-{NCoG-$u+zh~JR4tDaXuE4 zvBPSoLvFDzIh=r7q?3u0WT<;Ol#{lSa!fB*@3fBDb?!*uVVX~knqx6qRxcAottc71 zRnHlth3|AGa!Z8O@v`x>ViqEW_&U; zU@OK~J;ePecLEv!*aL1v{)>E+muEGXPx$}pr{aNnpKQp_`5A$N|BckLx~g0)twoIj z{0L@6P-er)d$I`PL<6W6r4dvSY4g~gz-bM-#ab)l({J*b8M1dP9C_q3T^uQ66@|X_ z8wv;xFjAwThZEA!jIMO9z*3?_z<#A3a6uKyOob0X8()E)We(GoLxoQ_3OG*a3-RgT zMG4v!8u=P3t1~zYuAZ;{itxT%52eH&ads0y=Uqhw(`V>!Y^STnRi^Q>IN)ONfN34X z{Bd0*ipW|d1ByjEf*#zFLJ`S|@Ci~llxqLr&yFpfEk=MqZsrN@4w1`B4v z7KSn*%_~p>X;1LA_jUui5mKT0Qpa2*VcM&rFEmGm){3gc17`=j_>dYD>;nP zBwMt^ZpY-8=R^=3i)6!MOhT{6sFNCt=cJiF+jPp$Q*Ss9HML3737D_39M6Vtp+?%x z-=*kd;`U;X@-BIFjAuf%VlV=gH&SgX?I=ycdyZf$te`wsczDvkwN<^8nDQW|sJC-lOgO_FPaCZSML}4A6>_Ot zvDaW60_Kg^R$Q|&|5juZi#wEoc2^7`%t-1`B_0LIe)dQ!u6SSy1_XV^QS(S?+Pcm1 zN|r-hMW4xd;UF(HtjNH6JvTHSFI4O`-FUj8%h-FQ_$`N_?6)+BN7_dp9uE*k{LZRS5gqWdC7{?~NppvNK-X575 zWk}Rz-?QRgPpmW9eIe6{dRI``;0r~-9F#6&F__;MdlLvuXa5v__+!`zJ$Bi{)*2V} zzWhqzo#Sr=SfWOO_0|+Km7VUkKmOI|`*gxqb*KBla$6^%^NlU4Gm&T@0YVfnt_0g` zUcaljO{0J@I2c1DDNcX5>q>JtB6ZK|MNWxkin(m+n|~zjQ)=ETf?$qEJKKJ*s?t;!PXLSnrZ^ zW>3YKVTHwa*-gmF%>I1bR=cW*+f$?v4&0v@8upDKCPS%dkO!cq>LAq?FgE}}SoOin zkriEE!9&aAJ|2o3HH)5>Q7kRT3)Mt;Rac#A@8ov|6EHU3w_DZgRdvlT98=tbg_lDK zM)G9JHw%7ja`>Gh@f)^I;#lsx%6#oxrFxbxa4VM8-xt;e_E=T~H>BIQV-c58&Qw$+ zj7vLCQx#4kmduDMs~Egbf7*U)W3y}tEI@WsHSl0e$J;Sv>|VC zf0?h1U(10=loX52R3@lpZ|<&m=9ae1K(#$C*LS?IhSURM}j%oA`24 zU2W%%n)YTbgt!;%^6zYhUWQr5 zPi=EJ`K2zj;EwvVJMB&TfDL7t9BueyQl5dR0mu}&saxBQIvxR!6a;}0P7=Sry#^AL zmJmMqcv1k_ck6)Kw%sfib_NljnbnHSpv030(V?eSzV1=f*!us#rSCveXh8~ zQ)2%Z_d3q?qR-xubkT}Y$Z>ckF9nvM6w1TWq~Iby!PR>T`PqdPF%EuvT-Q}FH*6(p zrhv>5ETKX)j7lOtB(LqQ`03U}hac}7ALJMW9c&m*OSo1Bxbi?Wk_cG!eUjPSky$5c zwU^1L4gG>iuX{dyBC{y^{LB=+kVS=MK&?}Sn1c+lJtYTnEqzPJ{j5? zb`hIv9nxWv)zk=cETPIivU|@o7`*(a(#_Oqn>1G=0SaxHI8yJP3^#}@$_?=`7wlu~ zhxD*WrM4+pFfx7;MSQq28PFg;t0nCOOQ>f*@VF(bscyV|vwdgkHeDQkwDtN9k&wfH zWl|V}Nf4qVd~mcOm%cHMe1ECu!LZRu+;}pyJ%;dN%k#MR8gHcB+}AT6kn+`@Q)i|8B{J!pO zbxi-JyTH?@m8yp-W2cN+GzTBw-(wWL_lEx4o0-oh^Vjo`q|xerFP+G&~&YZDrE@9Q*rvRKo?q_`jd`E(5cTvtwT z)hK)cHZVq@T#C%^hh>}x`~4Y72Yl-dKED6nIHJw7 zTPci4PEHn6Xk#vDQPWKw`f0CbL16fCpN_Q))H`)3@u2MTPo1wbSfHp{8~QW4$;+u( zu$3Vhu}t4u4Cet)6vmZ!RU`FKH-(P%?QB?eA(~_!2W)J|4zqTuxH)TwXMUYJZ44!P zG)*Gsp#q0+u#KnB_@MK4kp%6B$LTP=qyrVCv$(z$A9mSmqWI}w%P#W7jlm4&4HPpI zy98hh5P#K~6(SIgCY;5`N=I_cl6J3k+4m5L99UVKAy<5vC@wmBdn6U%Fhqy2ZP;a? zGNg|G-FKE_F!hIT)@zudEd?Haw_51LXOeejIX-1d3=$A&>-p%hPCF$L6ESx77L2bF zaiIF>OWP=%<7?g9+zM|x;EKL;v&MJ88Iyi<7aMp&-SZ-DE*hoa%mi}c$paMKw6rc9 zto_dxtr&>|ctzvj@f$W3_s0mT&Atvo7b~<*S0ZtbF;A=L_<>_o%seaD0ns@t2kvq{ zT#3cj0Ui)|!vDy?@Y``e=M4-rM)YUwkFv&(6H+&%PyBd80?Da9_Un4SJm$G-%_Wid ze3^OB&`-!vA{dJo*#r;kx2P%>Bqv_KT+&14{SevbP-pjwFV(LK$vhZ&fn|}|^NCN3 zNYiNRi@=a+nMyP!!Z5$8TZbKx*uHF^;d3Uza4BIW8vHt;K47T#CxFkgtS|`NdzsW% z;sJ%fHaUZ4z9}*Bbj!v+FQHO$X0j;$%{pc zH^qL`X%;R?GJsj!XKKjEs3VLj0`|kCW|QJjR}>UHIQs1m>-bg9eY34L1|Q?t>?G=> z>jM!eI$03213DoJC^c7i83i%K9%P{?K5X*hthFWkL`C!h!A%7tUIEq=@_WkRj_Gp# z8a-8Ri_>VaZ4p&d!(=p-{axA2++o3xJ(d9EaMLmIF364fW~N6r%MW)Ejzt#kYKfpE zEnB-!o@y;oZz#T0_JuMn9wJ#{mE|IsMLnLlXBJg6J;j8`gR^5IZ)sO9^up6WZ8Qu) zmh6!63Bj9QrjK(jwd58}(|u)Qan)OJhF}}@&akqOCE0-`mQ?pGi#F>*d>8J>jyXgc zX}hz!d&nP)w|mMo14agpcbyE`z!nIPYrDV<*4!LVFjU19o|>KFAzDczm(tlK`cHiH z#x+chsztX`Qt8=|_n?$H!*zUbq_cBVE<`mnzWG|KUABli}*?+5Nn90BWU%%1`})Mn;f2u)jCq{INs_{i^uq zRxaE@yyl)FsPXGE{GOZl21--?!;g4_`F=q;JFevWJ*NZ!e#mb(!H}DoId=2U!0V!!Iob zP?)Rv5u|oW$#?h*>{da3e;)3xf;3zbTNb9WvI(p z_s*gA|NlWEq5h>q z3@}dw@eSgDCKdqo$kl{mpa^onTLm{(FMlHZ6b1ri_@ixHNDuQ*mTxPhK zpaYZvmj1tDxVBwfO^g8wLjXLhzOhRAl_mq!8CUaMfZFfBY5NzlUVw7^Xc!k$27q!P zu-vd8E^u61F+YGVO0RkA%f7iN9Suq$!*heaxhmXz8RW8N^f}7M{}$xh3c4y8ea-_^ zG2*>R*Idv_zU-FE63yorzCd~68+)36Y9IWyH2zzcTvSCqX8|U!;r|b4uFi^n)XQas z<8uskf&UERT9^EgjJ&8=e9i&@U<>{SG(Yu=L0icWh>J48pb%6-{~5&Jy5yoPFDQ+e z@P9ya_YX<1%PzSn!3zp8^WQ;S>yqpAcF%d9i~I*JxmJDmvWG6J-kuWy0Kq^N(HrYp zE=a&$X1FXodrlD|_FpkvTS-^dU(ZnhfT;U74|BD1`@wKg!xfZ4>A`=+aIHhG3bBI1 z;EVrzn7@%_1#KEvwG2UxtH}Ig<3HteE}S3yl7_kP>i?u{2ugTW)DV>L%fBT&mpHs^ z?4l$gsIfP|bCrMiwElF*AI8oF3PCMirzUuAQyCa<`L8VgI-B_A{9mv9owgt-)eom% z)D}Ev0sub#TdKcR8U(d{otoacbrbo2>5)HUP=ER3&);c5U;m{_1j=(&Tko6(09gG^ zo@+EOu2VhxAC&e$S+CRBJEsj+_&wiU)e!i5R1g)nYrT3^aqpZH0H6UXYyYcu|7UGp zQrEi<^WsJ9YZkvWyd@bE|3V!EwwyMAB#q&s~zZ-~jE)}_!@~WQS zIU_Jhn%a#~g2rS0y*vL_-4FChx~l63%3Sd;m@i6e{NYeggI5KrKn-dG({KFKA?BjN zYld!6^VezkoCCbmzajG=11+fa>!eH0tqTHE(fsCzzc_w^n!c)Oac&p@NCoO;|E}qa zqavv7>(mR*t=}{IZQEA|I#BahZ-Ad02MT;x-jw-^BOEBf)oZ1o1PQjkO>ku}0=0hi zt{A9wF^8M64l=@k8ow^I{@i@H+ix2O89PAjUX8duw+g&6_xy(J{t|%&wS6@h7u2@0 e*A3bR9SUS6p@6pmfeE02-|W=DbVj~Ee*1rA5$4VS literal 0 HcmV?d00001 diff --git a/src/vendormodules/tomlish-1.1.4.tm b/src/vendormodules/tomlish-1.1.4.tm index 33d5b912..c472eace 100644 --- a/src/vendormodules/tomlish-1.1.4.tm +++ b/src/vendormodules/tomlish-1.1.4.tm @@ -81,6 +81,15 @@ namespace eval tomlish { namespace export {[a-z]*}; # Convention: export all lowercase variable types + #default interp recursionlimit of 1000 is insufficient to pass 1000 deep nested structures as in certain toml tests. + #e.g https://github.com/iarna/toml-spec-tests/tree/latest/values + #1000 seems deep for a 'configuration' format - but toml sometimes used for other serialisation purposes. + #todo - review + set existing_recursionlimit [interp recursionlimit {}] + if {$existing_recursionlimit < 5000} { + interp recursionlimit {} 5000 + } + #IDEAS: # since get_toml produces tomlish with whitespace/comments intact: # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace @@ -102,6 +111,38 @@ namespace eval tomlish { # 4 = NEWLINE lf # 5 = NEWLINE lf + #This reordering idea is complicated by the nature of tablearrays - especially as a table header references last tablearrayname, + # and duplicate table headers are allowed in that context. + #e.g + #[[fruits]] + # name="apple" + # [fruits.metadata] + # id=1 + # + #[unrelated1] + # + #[[fruits]] + # name="pear" + # + #[unrelated2] + # silly="ordering" + # + #[fruits.metadata] + #id=2 + #The TABLEARRAY record can't be completely selfcontained on the default parsing mechanism - because it is legal (though not recommended) to have unrelated tables in between. + #If we were to 'insert' later related records (such as the 2nd [fruits.metadata] above) into the TABLEARRAY structure - then, even though it might produce 'nicer' toml, + # we would lose roundtripability toml->tomlish->toml + # ----------------------------------------------------- + #REVIEW + #todo - some sort of 'normalize'/'grouping' function on tomlish that at least makes records self-contained, and perhaps then (optionally) reorders resulting records sensibly. + #such a function on the tomlish may work - although it would be unwise to duplicate the validation aspects of to_dict + #The most practical way might be to use to_dict followed by from_dict - but that would lose comment info and formatting. + #In the above example - The decision by the toml author to put [unrelated1] between related tablearrays should be respected, + #but the positioning of [unrelated2] between a tablearray and one of its contained tables is suspect. + #Both [fruits.metadata] table records should theoretically be added as children to their corresponding [[fruits]] tablearray record in the tomlish. (just as their name keys are) + # ----------------------------------------------------- + + #ARRAY is analogous to a Tcl list #TABLE is analogous to a Tcl dict @@ -118,6 +159,7 @@ namespace eval tomlish { #removed - ANONTABLE #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + #todo - configurable - allow empty string for 'unlimited' set min_int -9223372036854775808 ;#-2^63 set max_int +9223372036854775807 ;#2^63-1 @@ -299,21 +341,22 @@ namespace eval tomlish { #(update - only Creating and Defining are relevant terminology) #review - #tablenames_info keys created, defined, createdby, definedby, closedby + #tablenames_info keys type created, defined, createdby, definedby, closedby ??? review keys + # [tname] = header_table [[tname]] = header_tablearray #consider the following 2 which are legal: - #[table] #'table' created, defined=open definedby={header table} + #[table] #'table' created, defined=open type header_table #x.y = 3 - #[table.x.z] #'table' defined=closed closedby={header table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header table.x.z} + #[table.x.z] #'table' defined=closed closedby={header_table table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header_table table.x.z} #k= 22 # #'table.x.z' defined=closed closedby={eof eof} #equivalent datastructure - #[table] #'table' created, defined=open definedby={header table} - #[table.x] #'table' defined=closed closedby={header table.x}, 'table.x' created defined=open definedby={header table.x} + #[table] #'table' created, defined=open definedby={header_table table} + #[table.x] #'table' defined=closed closedby={header_table table.x}, 'table.x' created defined=open definedby={header_table table.x} #y = 3 - #[table.x.z] #'table.x' defined=closed closedby={header table.x.z}, 'table.x.z' created defined=open definedby={header table.x.z} + #[table.x.z] #'table.x' defined=closed closedby={header_table table.x.z}, 'table.x.z' created defined=open definedby={header_table table.x.z} #k=22 #illegal @@ -439,14 +482,285 @@ namespace eval tomlish { } TABLEARRAY { - set tablename [lindex $item 1] - log::debug "---> to_dict processing item TABLENAME (name: $tablename): $item" - set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + + set NEST_DICT [dict create] ;#first blush attempt at referencing supertable tablearrays + set tablearrayname [lindex $item 1] + log::debug "---> to_dict processing item TABLENAME (name: $tablearrayname): $item" + set norm_segments [::tomlish::utils::tablename_split $tablearrayname true] ;#true to normalize #we expect repeated tablearray entries - each adding a sub-object to the value, which is an array/list. + #tablearrayname is likely to appear multiple times - so unlike a TABLE we don't check for 'defined' for the full name as an indicator of a problem + set supertable [list] + ############## + # [[a.b.c.d]] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of tablearray name $tablearrayname already has data but doesn't appear to be a table - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_supertable_keycollision + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } else { + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #REVIEW!! + # what happens with from_toml {[[a.b.c]]} {[[a]]} ??? + dictn set tablenames_info [list $supertable type] header_table ;#how do we know it's not going to be a tablearray? + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } else { + #supertable has already been created - and maybe defined - but even if defined we can add subtables unless it is of type itable + #but if it's a tablearray - we need to point to the most 'recently defined table element of the array' + #(another way of saying last member of that array)?? + set supertype [dictn get $tablenames_info [list $supertable type]] + if {$supertype eq "header_tablearray"} { + puts stdout "todict!!! TABLEARRAY nesting required for supertable [join $supertable .]" + puts stdout "todict!!! todo.." + #how to do multilevel nesting?? + set EXISTING_SUPERARRAY_ELEMENTS [dict get $datastructure {*}$supertable value] + dict set NEST_DICT $supertable $EXISTING_SUPERARRAY_ELEMENTS + puts stdout "todict!!! supertable '[join $supertable .]' elements $EXISTING_SUPERARRAY_ELEMENTS" + } + } + } + # + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + #first encounter of this tablearrayname + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[[a]]} + set msg "Cannot create tablearray name $tablearrayname. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_direct_keycollision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no collision - we can create the tablearray and the array in the datastructure + dictn set tablenames_info [list $norm_segments type] header_tablearray + dict set datastructure {*}$norm_segments [list type ARRAY value {}] + set ARRAY_ELEMENTS [list] + } else { + #we have a table - but is it a tablearray? + set ttype [dictn get $tablenames_info [list $norm_segments type]] + #use a tabletype_unknown type for previous 'created' only tables? + if {$ttype ne "header_tablearray"} { + set msg "tablearray name $tablearrayname already appears to be already created as a table not a tablearray - invalid?" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #add to array + #error "add_to_array not implemented" + #{type ARRAY value } + set ARRAY_ELEMENTS [dict get $datastructure {*}$norm_segments value] + } + + + set object [dict create] ;#array context equivalent of 'datastructure' + set objectnames_info [dict create] ;#array contex equivalent of tablenames_info + + #add to ARRAY_ELEMENTS and write back in to datastructure. + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #MAINTENANCE: temp copy from TABLE + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [_get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + #set supertable $norm_segments + set supertable [list] ;#disconnect from main structure - each array element is a new context for key paths! + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey '$dottedkeyname' kv: $keyval_dict" + #dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #wrong + #TODO!!!!!!!!!!!!! + #lappend ARRAY_ELEMENTS [list $dottedkeyname $keyval_dict] + dict set object $dottedkeyname $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + TABLE { + #we should be able to process tablearray subtables either as part of the tablearray record, or independently. + #(or even a mixture of both, although that is somewhat an edge case) + #[[fruit]] + #x=1 + # [fruit.metadata] + # [fruit.otherdata] + + #when processing a dict destined for the above - the tomlish generator (e.g from_dict) + #should create as 1 or 3 records (but could create 2 records if there was an unrelated table in between the subtables) + #choices: all in tablearray record, tablearray + 1 or 2 table records. + # + #We are going the other way here - so we just need to realize the list of tables 'belonging' to this tablearray might not be complete. + # + #the subtable names must be prefixed with the tablearray - we should validate that for any contained TABLE records + + } + default { + error "Sub element of type '$type' not understood in tablearray context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + #todo? + ##end of TABLE record - equivalent of EOF or next header - close off the dottedtables + #foreach dtablepath $dottedtables_defined { + # dictn set tablename_info [list $dtablepath defined] closed + #} + + if {[dict size $NEST_DICT]} { + puts "reintegrate?? $NEST_DICT" + #todo - more - what if multiple in hierarchy? + dict for {superpath existing_elements} $NEST_DICT { + #objects stored directly as dicts in ARRAY value + set lastd [lindex $existing_elements end] + #insufficient.. + #dict set lastd [lindex $norm_segments end] [list type ITABLE value $object] + dict set lastd [lindex $norm_segments end] $object + #set lastd [dict merge $lastd $object] + lset existing_elements end $lastd + dict set datastructure {*}$superpath [list type ARRAY value $existing_elements] + } + } else { + #lappend ARRAY_ELEMENTS [list type ITABLE value $object] + lappend ARRAY_ELEMENTS $object + dict set datastructure {*}$norm_segments [list type ARRAY value $ARRAY_ELEMENTS] + } } TABLE { set tablename [lindex $item 1] + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + #As our TABLE record contains all it's child DOTTEDKEY records - this should be equivalent to setting them as defined at EOF or next header. + log::debug "---> to_dict processing item TABLE (name: $tablename): $item" #set tablename [::tomlish::utils::tablename_trim $tablename] set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize @@ -456,7 +770,8 @@ namespace eval tomlish { #our tablename e.g [a.b.c.d] declares a space to 'define' subkeys - but there has already been a definition space for this path set msg "Table name $tablename has already been directly defined in the toml data. Invalid" append msg \n [tomlish::dict::_show_tablenames $tablenames_info] - error $msg + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg } @@ -476,29 +791,33 @@ namespace eval tomlish { #supertable with this path doesn't yet exist if {[dict exists $datastructure {*}$supertable]} { #There is data though - so it must have been created as a keyval - set msg "Supertable [join $supertable .] of table name $tablename already has data - invalid" + set msg "Supertable [join $supertable .] of table name $tablename already has data but doesn't appear to be a table (keycollision) - invalid" append msg \n [tomlish::dict::_show_tablenames $tablenames_info] - error $msg - } else { - #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here - dictn set tablenames_info [list $supertable type] header - #ensure empty tables are still represented in the datastructure - dict set datastructure {*}$supertable [list] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] header_table + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] } else { - #supertable has already been created - and maybe defined - but even if defined we can add subtables + #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable + } } #table [a.b.c.d] hasn't been defined - but may have been 'created' already by a longer tablename # - or may have existing data from a keyval if {![dictn exists $tablenames_info [list $norm_segments type]]} { if {[dict exists $datastructure {*}$norm_segments]} { - set msg "Table name $tablename already has data - invalid" + #e.g from_toml {a=1} {[a]} + set msg "Cannot create table name $tablename. Key already has data but key doesn't appear to be a table (keycollision) - invalid" append msg \n [tomlish::dict::_show_tablenames $tablenames_info] - error $msg + #raise a specific type of error for tests to check + #test: datastructure_tablename_keyval_collision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg } #no data or previously created table - dictn set tablenames_info [list $norm_segments type] header + dictn set tablenames_info [list $norm_segments type] header_table #We are 'defining' this table's keys and values here (even if empty) dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here @@ -512,47 +831,131 @@ namespace eval tomlish { log::debug "----> todict processing $tag subitem $type processing contained element $element" switch -exact -- $type { DOTTEDKEY { + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? set dkey_info [_get_dottedkey_info $element] #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) - set dotted_key_hierarchy [dict get $dkey_info keys] - set dkeys [lrange $dotted_key_hierarchy 0 end-1] - set leaf_key [lindex $dotted_key_hierarchy end] - #ensure empty keys are still represented in the datastructure - set test_keys $norm_segments - foreach k $dkeys { - lappend test_keys $k - if {![dict exists $datastructure {*}$test_keys]} { - dict set datastructure {*}$test_keys [list] + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + set supertable $norm_segments + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # } else { - tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } } } + #assert - dottedkey represents a key val pair that can be added + - if {[dict exists $datastructure {*}$norm_segments {*}$dkeys $leaf_key]} { - error "Duplicate key '$norm_segments $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg } + set keyval_dict [_get_keyval_value $element] #keyval_dict is either a {type value } #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level #punk::dict::is_tomlish_typeval can distinguish - puts stdout "to_dict>>> $keyval_dict" - dict set datastructure {*}$norm_segments {*}$dkeys $leaf_key $keyval_dict - #JMN 2025 - #lappend tablenames_info [list {*}$norm_segments {*}$dkeys] - set tkey [list {*}$norm_segments {*}$dkeys] - dictn incr tablenames_info [list $tkey seencount] + puts stdout "to_dict>>> TABLE/dottedkey $dottedkeyname kv: $keyval_dict" + dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #remove ? if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys # inner structure will contain {type value } if all leaves are not empty ITABLES - set tkey [list {*}$norm_segments {*}$dkeys $leaf_key] + set tkey [list {*}$norm_segments {*}$all_dotted_keys] #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] - dictn incr tablenames_info [list $tkey seencount] - #if the keyval_dict is not a simple type x value y - then it's an inline table ? - #if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. - dictn set tablenames_info [list $tkey closed] 1 + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 } } @@ -564,6 +967,14 @@ namespace eval tomlish { } } } + + #end of TABLE record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dictn set tablename_info [list $dtablepath defined] closed + } + + + #review??? #now make sure we add an empty value if there were no contained elements! #!todo. } @@ -889,24 +1300,74 @@ namespace eval tomlish { } } - proc _from_dictval {parents tablestack keys vinfo} { - set k [lindex $keys end] - if {[regexp {\s} $k] || [string first . $k] >= 0} {} - if {![::tomlish::utils::is_barekey $k]} { - #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + #take a raw string and classify: result is a 2 element list comprised of KEY|SQKEY|DQKEY and the value being the appropriate inner string + proc _from_dict_classify_key {rawval} { + if {![::tomlish::utils::is_barekey $rawval]} { #requires quoting - #we'll use a basic mechanism for now to determine the type of quoting - whether it has any single quotes or not. + # + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + # + #we'll use a basic mechanisms for now to determine the type of quoting + # - whether it has any single quotes or not. + # (can't go in an SQKEY) + # - whether it has any chars that require quoting when in a Bstring + # (if so - then its visual representation might be unsuitable for a key in a toml text file, so escape and put in DQKEY instead of literal SQKEY) #todo - more? + #REVIEW - the backslash might often be in things like a regex or windows path - which is often better expressed in a literal SQKEY + # from literal examples: + # 'c:\Users\nodejs\templates' + # '<\i\c*\s*>' + #If these are in *keys* our basic test will express these as: + # "c:\\Users\\nodejs\\templates" + # "<\\i\\c*\\s*>" + # This still works - but a smarter test might determine when SQKEY is the better form? + #when coming from external systems - can we even know if the value was already escaped? REVIEW + #Probably when coming from json - we know it's already escaped - and so we build our dict converting keys to unescaped + #TODO - clarify in documentation that keys resulting from to_dict are in 'normalized' (unescaped) form + # #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) - if {[string first ' $k] >=0} { + set k_escaped [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + if {[string length $k_escaped] != [string length $rawval]} { + #escaping made a difference + set has_escape_requirement 1 + } else { + set has_escape_requirement 0 + } + if {[string first ' $rawval] >=0 || $has_escape_requirement} { #basic string + # (any ANSI SGR sequence will end up here in escaped form ) + return [list DQKEY $k_escaped] } else { #literal string - set K_PART [list SQKEY $k] + return [list SQKEY $rawval] } } else { - set K_PART [list KEY $k] + return [list KEY $rawval] + } + } + + #the quoting implies the necessary escaping for DQKEYs + proc _from_dict_join_and_quote_raw_keys {rawkeylist} { + set result "" + foreach rk $rawkeylist { + lassign [_from_dict_classify_key $rk] type val + switch -- $type { + SQKEY { + append result "'$val'." + } + DQKEY { + append result "\"$val\"." + } + KEY { + append result "$val." + } + } } + return [string range $result 0 end-1] + } + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + set K_PART [_from_dict_classify_key $k] ;#get [list SQKEY ] puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" puts stderr "---tablestack: $tablestack---" set result [list] @@ -918,7 +1379,6 @@ namespace eval tomlish { set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} } else { - #set result [list TABLE $k {NEWLINE lf}] if {$vinfo ne ""} { #set result [list DOTTEDKEY [list [list KEY $k]] = ] @@ -930,8 +1390,8 @@ namespace eval tomlish { set result [list DOTTEDKEY [list $K_PART] =] set records [list ITABLE] } else { - #review - quoted k ?? - set result [list TABLE $k {NEWLINE lf}] + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + set result [list TABLE $tname {NEWLINE lf}] set tablestack [list {*}$tablestack [list T $k]] set records [list] } @@ -941,13 +1401,17 @@ namespace eval tomlish { set lastidx [expr {[dict size $vinfo] -1}] set dictidx 0 dict for {vk vv} $vinfo { - if {[regexp {\s} $vk] || [string first . $vk] >= 0} { - set VK_PART [list SQKEY $vk] - } else { - set VK_PART [list KEY $vk] - } + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + #(SQKEY & DQKEY do not have the enclosing quotes in their returned val) + #if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + # set VK_PART [list SQKEY $vk] + #} else { + # set VK_PART [list KEY $vk] + #} if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y + #REVIEW - we could detect if value is an array of objects, + #and depending on parent context - emit a series of TABLEARRAY records instead of a DOTTEDKEY record containing an ARRAY of objects set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] } else { @@ -956,8 +1420,11 @@ namespace eval tomlish { if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] - set tname [join [list {*}$keys $vk] .] - set record [list TABLE $tname {NEWLINE lf}] + + #we can't just join normalized keys - need keys with appropriate quotes and escapes + #set tname [join [list {*}$keys $vk] .] ;#WRONG + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] set tablestack [list {*}$tablestack [list T $vk]] } else { set record [list DOTTEDKEY [list $VK_PART] = ITABLE] @@ -968,8 +1435,8 @@ namespace eval tomlish { #experiment.. sort of getting there. if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" - set tname [join [list {*}$keys $vk] .] - set record [list TABLE $tname {NEWLINE lf}] + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] set tablestack [list {*}$tablestack [list T $vk]] #review - todo? @@ -1004,9 +1471,10 @@ namespace eval tomlish { } } else { if {$lastparent eq "do_inline"} { - lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} + lappend result DOTTEDKEY [list $K_PART] = ITABLE {NEWLINE lf} } else { - lappend result TABLE $k {NEWLINE lf} + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + lappend result TABLE $tname {NEWLINE lf} } } } @@ -1020,8 +1488,9 @@ namespace eval tomlish { if {$lastparent eq "TABLE"} { #review dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] - lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] + lappend result [list DOTTEDKEY [list $VK_PART] = $dottedkey_value {NEWLINE lf}] } } else { if {$vinfo ne ""} { @@ -1033,11 +1502,7 @@ namespace eval tomlish { set result ITABLE set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] dict for {vk vv} $vinfo { - if {[regexp {\s} $vk] || [string first . $vk] >=0} { - set VK_PART [list SQKEY $vk] - } else { - set VK_PART [list KEY $vk] - } + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] @@ -1049,7 +1514,7 @@ namespace eval tomlish { # (including what's been inlined already) #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { # puts stderr "_from_dictval uninline2 KEY $keys" - # set tname [join [list {*}$keys $vk] .] + # set tname [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] # set record [list TABLE $tname {NEWLINE lf}] # set tablestack [list {*}$tablestack [list T $vk]] #} else { @@ -1141,6 +1606,11 @@ namespace eval tomlish { set parents [list ""] } set keys [list $t] + #review - where to make decision on + # DOTTEDKEY containing array of objs + #vs + # list of TABLEARRAY records + #At least for the top set trecord [_from_dictval $parents $tablestack $keys $tinfo] lappend tomlish $trecord incr dictposn @@ -1180,6 +1650,7 @@ namespace eval tomlish { proc get_json {tomlish} { package require fish::json set d [::tomlish::to_dict $tomlish] + #return [::tomlish::dict_to_json $d] return [fish::json::from "struct" $d] } @@ -1970,10 +2441,6 @@ namespace eval tomlish::decode { #todo - check not something already waiting? tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space } - XXXdquotedkey { - #todo - set v($nest) [list DQKEY $tok] ;#$tok is the keyname - } barekey { switch -exact -- $prevstate { table-space - itable-space { @@ -2165,17 +2632,31 @@ namespace eval tomlish::decode { untyped_value { #would be better termed unclassified_value #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + unset -nocomplain tag if {$tok in {true false}} { set tag BOOL - } elseif {[::tomlish::utils::is_int $tok]} { - set tag INT - } elseif {[::tomlish::utils::is_float $tok]} { - set tag FLOAT - } elseif {[::tomlish::utils::is_datetime $tok]} { - set tag DATETIME } else { - error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + if {[::tomlish::utils::is_int $tok]} { + set tag INT + } else { + if {[string is integer -strict $tok]} { + #didn't qualify as a toml int - but still an int + #probably means is_int is limiting size and not accepting bigints (configurable?) + #or it didn't qualify due to more than 1 leading zero + #or other integer format issue such as repeated underscores + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. (looks close to being an int. Formatting or range issue?) [tomlish::parse::report_line] (no space level change)" + } else { + if {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok]} { + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + } + } } + #assert either tag is set, or we errored out. lappend v($nest) [list $tag $tok] } @@ -2567,7 +3048,7 @@ namespace eval tomlish::utils { dict set Bstring_control_map \n {\n} dict set Bstring_control_map \r {\r} dict set Bstring_control_map \" {\"} - #dict set Bstring_control_map \x1b {\e} ;#should presumably be only be a convenience for decode - going the other way we get \u001B + dict set Bstring_control_map \x1b {\e} ;#In spec it's included in the list of 'must be escaped', as well as the 'convenience' escapes - so we make it go both ways. dict set Bstring_control_map \\ "\\\\" #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ @@ -2951,14 +3432,18 @@ namespace eval tomlish::utils { if {![tcl::string::is integer -strict $numeric_value]} { return 0 } + + + #!todo - check bounds only based on some config value - #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements by default (for now) #presumably very large numbers would have to be supplied in a toml file as strings. #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max - if {$numeric_value > $::tomlish::max_int} { + #some question around implementations allowed to use lower values such as 2^31 on some systems? + if {$::tomlish::max_int ne "" && $numeric_value > $::tomlish::max_int} { return 0 } - if {$numeric_value < $::tomlish::min_int} { + if {$::tomlish::min_int ne "" && $numeric_value < $::tomlish::min_int} { return 0 } } else { @@ -3076,8 +3561,52 @@ namespace eval tomlish::utils { } } - #review - we + proc is_datepart {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + + return 1 + } + proc is_localdate {str} { + is_datepart $str + } + proc is_timepart {str} { + set numchars [tcl::string::length $str] + #timepart can have negative or positive offsets so - and + must be accepted + if {[regexp -all {[zZt0-9\-\+\.:]} $str] == $numchars} { + #todo + return 1 + } else { + return 0 + } + } + proc is_localtime {str} { + #time of day without any relation to a specific day or any offset or timezone + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\.:]} $str] == $numchars} { + #todo + return 1 + } else { + return 0 + } + } + + #review proc is_datetime {str} { + #Essentially RFC3339 formatted date-time - but: + #1) allowing seconds to be omitted (:00 assumed) + #2) T may be replaced with a single space character TODO - parser support for space in datetime! + # (RFC 3339 allows space instead of T also - but doesn't specify it *must* be a single space) + + #toml-lint @2025-04 doesn't accept t for T or z for Z - but RFC3339 does + #toml spec doesn't clarify - we will accept + #e.g 1979-05-27 #e.g 1979-05-27T00:32:00Z #e.g 1979-05-27 00:32:00-07:00 @@ -3086,20 +3615,53 @@ namespace eval tomlish::utils { #review #minimal datetimes? - # 2024 ok - shortest valid 4 digit year? + # 2024 not ok - 2024T not accepted by tomlint why? # 02:00 ok - # 05-17 ok - if {[string length $str] < 4} { + # 02:00:00.5 ok + # 1:00 - not ok - RFC3339 requires 2-digit hr,min,sec + + #toml-lint.com accepts 2025-01 + + if {[string length $str] < 5} { return 0 } - set matches [regexp -all {[zZtT0-9\-\+\.:]} $str] + set matches [regexp -all {[zZtT0-9\ \-\+\.:]} $str] if {[tcl::string::length $str] == $matches} { #all characters in legal range + if {[regexp -all {\ } $str] > 1} { + #only a single space is allowed. + return 0 + } + #If we get a space - it is only valid as a convience to represent the T separator + #we can normalize by converting to T here before more tests + set str [string map {" " T t T} $str] + #a further sanity check on T + if {[regexp -all {T} $str] > 1} { + return 0 + } + #!todo - use full RFC 3339 parser? - lassign [split $str T] datepart timepart #!todo - what if the value is 'time only'? + if {[string first T $str] > -1} { + lassign [split $str T] datepart timepart + if {![is_datepart $datepart]} { + return 0 + } + if {![is_timepart $timepart]} { + return 0 + } + } else { + #either a datepart or a localtime + #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day + # without any relation to a specific day or any offset or timezone." + if {!([is_datepart $str] || [is_localtime $str])} { + return 0 + } + } + + #Tcl's free-form clock scan (no -format option) is deprecated # #if {[catch {clock scan $datepart} err]} { @@ -3107,7 +3669,6 @@ namespace eval tomlish::utils { # return 0 #} - #!todo - verify time part is reasonable } else { return 0 } @@ -3814,9 +4375,7 @@ namespace eval tomlish::parse { #set next [list PUSHSPACE [lindex $transition_to 1]] set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 - #::tomlish::log::notice "goNextState REENTRANCY. calling goNextState $nexttokentype $tokentype" - #set result [::tomlish::parse::goNextState $nexttokentype $tokentype] - ::tomlish::log::debug "--->> zeropoppushspace goNextState REENTRANCY. calling goNextState $nexttokentype $currentstate" + ::tomlish::log::debug "--->> zeropoppushspace goNextState RECURSE. calling goNextState $nexttokentype $currentstate" set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] set result [dict get $transition_info newstate] } @@ -6040,14 +6599,22 @@ namespace eval tomlish::dict { } } -tcl::namespace::eval tomlish::app { - variable applist [list encoder decoder test] +tcl::namespace::eval tomlish::app { #*** !doctools #[subsection {Namespace tomlish::app}] #[para] #[list_begin definitions] + tcl::namespace::eval argdoc { + proc test_suites {} { + if {[package provide test::tomlish] eq ""} { + return [list] + } + return [test::tomlish::SUITES] + } + } + proc decoder {args} { #*** !doctools #[call app::[fun decoder] [arg args]] @@ -6101,14 +6668,28 @@ tcl::namespace::eval tomlish::app { exit 0 } + package require punk::args + punk::args::define { + @dynamic + @id -id ::tomlish::app::test + @cmd -name tomlish::app::test + @leaders + @opts -any 1 + -suite -default tests -choices {${[::tomlish::app::argdoc::test_suites]}} + @values -min 0 -max 0 + } proc test {args} { - set opts [dict merge [dict create] $args] - package require test::tomlish - if {[dict exists $opts -suite]} { - test::tomlish::suite [dict get $opts -suite] - } - test::tomlish::run + set argd [punk::args::parse $args withid ::tomlish::app::test] + set opts [dict get $argd opts] + set opt_suite [dict get $opts -suite] + test::tomlish::SUITE $opt_suite + #if {[catch {test::tomlish::SUITE $opt_suite} errM]} { + # puts stderr "Unknown test suite '$opt_suite'. Available suites: [test::tomlish::SUITES]" + # exit 1 + #} + set run_opts [dict remove $opts -suite] + test::tomlish::RUN } @@ -6150,40 +6731,61 @@ namespace eval tomlish::lib { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -if {$argc > 0} { - puts stderr "argc: $argc args: $argv" - - if {($argc == 1)} { - if {[tcl::string::tolower $argv] in {help -help h -h}} { - puts stdout "Usage: -app where appname one of:[tomlish::appnames]" - exit 0 - } else { - puts stderr "Argument '$argv' not understood. Try -help" - exit 1 - } +if {[info exists ::argc] && $::argc > 0} { + puts stderr "argc: $::argc args: $::argv" + set arglist $::argv + # -------------- + #make sure any dependant packages that are sourced don't get any commandline args + set ::argv {} + set ::argc 0 + # -------------- + package require punk::args + punk::args::define { + @dynamic + @id -id tomlish::cmdline + @cmd -name tomlish -help\ + "toml encoder/decoder written in Tcl" + @opts -any 1 + -help -type none -help\ + "display usage" + -app -choices {${[tomlish::appnames]}} } - set opts [dict create] - set opts [dict merge $opts $argv] - - set opts_understood [list -app ] - if {"-app" in [dict keys $opts]} { - #Don't vet the remaining opts - as they are interpreted by each app - } else { - foreach key [dict keys $opts] { - if {$key ni $opts_understood} { - puts stderr "Option '$key' not understood" - exit 1 - } - } - } - if {[dict exists $opts -app]} { - set app [dict get $opts -app] - if {$app ni [tomlish::appnames]} { - puts stderr "app '[dict get $opts -app]' not found" - exit 1 - } - tomlish::app::$app {*}$opts + set argd [punk::args::parse $arglist withid tomlish::cmdline] + lassign [dict values $argd] leaders opts values received + if {[dict exists $received -help] || ![dict exists $received -app]} { + #puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + puts stderr [punk::args::usage tomlish::cmdline] + exit 0 } + + set app [dict get $opts -app] + set appnames [tomlish::appnames] + set app_opts [dict remove $opts -app] + tomlish::app::$app {*}$app_opts + + #set opts [dict create] + #set opts [dict merge $opts $::argv] + + #set opts_understood [list -app ] + #if {"-app" in [dict keys $opts]} { + # #Don't vet the remaining opts - as they are interpreted by each app + #} else { + # foreach key [dict keys $opts] { + # if {$key ni $opts_understood} { + # puts stderr "Option '$key' not understood" + # exit 1 + # } + # } + #} + #if {[dict exists $opts -app]} { + # set app [dict get $opts -app] + # set appnames [tomlish::appnames] + # if {$app ni $appnames} { + # puts stderr "app '[dict get $opts -app]' not found. Available apps: $appnames" + # exit 1 + # } + # tomlish::app::$app {*}$opts + #} } ## Ready diff --git a/src/vendormodules/tomlish-1.1.5.tm b/src/vendormodules/tomlish-1.1.5.tm new file mode 100644 index 00000000..7ff93c3e --- /dev/null +++ b/src/vendormodules/tomlish-1.1.5.tm @@ -0,0 +1,6973 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# 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 tomlish 1.1.5 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.5] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #default interp recursionlimit of 1000 is insufficient to pass 1000 deep nested structures as in certain toml tests. + #e.g https://github.com/iarna/toml-spec-tests/tree/latest/values + #1000 seems deep for a 'configuration' format - but toml sometimes used for other serialisation purposes. + #todo - review + set existing_recursionlimit [interp recursionlimit {}] + if {$existing_recursionlimit < 5000} { + interp recursionlimit {} 5000 + } + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + #This reordering idea is complicated by the nature of tablearrays - especially as a table header references last tablearrayname, + # and duplicate table headers are allowed in that context. + #e.g + #[[fruits]] + # name="apple" + # [fruits.metadata] + # id=1 + # + #[unrelated1] + # + #[[fruits]] + # name="pear" + # + #[unrelated2] + # silly="ordering" + # + #[fruits.metadata] + #id=2 + #The TABLEARRAY record can't be completely selfcontained on the default parsing mechanism - because it is legal (though not recommended) to have unrelated tables in between. + #If we were to 'insert' later related records (such as the 2nd [fruits.metadata] above) into the TABLEARRAY structure - then, even though it might produce 'nicer' toml, + # we would lose roundtripability toml->tomlish->toml + # ----------------------------------------------------- + #REVIEW + #todo - some sort of 'normalize'/'grouping' function on tomlish that at least makes records self-contained, and perhaps then (optionally) reorders resulting records sensibly. + #such a function on the tomlish may work - although it would be unwise to duplicate the validation aspects of to_dict + #The most practical way might be to use to_dict followed by from_dict - but that would lose comment info and formatting. + #In the above example - The decision by the toml author to put [unrelated1] between related tablearrays should be respected, + #but the positioning of [unrelated2] between a tablearray and one of its contained tables is suspect. + #Both [fruits.metadata] table records should theoretically be added as children to their corresponding [[fruits]] tablearray record in the tomlish. (just as their name keys are) + # ----------------------------------------------------- + + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE TABLEARRAY WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #removed - ANONTABLE + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + #todo - configurable - allow empty string for 'unlimited' + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + #find the value (or 2 values if space separated datetime - and stitch back into one) + # 3 is the earliest index at which the value could occur (depending on whitespace) + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keys are lists {parenttable subtable etc} corresponding to parenttable.subtable.etc + } + set sublist [lrange $keyval_element 2 end] + + set values [list] + set value_posns [list] + set posn 0 + foreach sub $sublist { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + lappend values $sub + lappend value_posns $posn + } + default {} + } + incr posn + } + switch -- [llength $values] { + 0 { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + 1 { + lassign [lindex $values 0] type value + } + 2 { + #validate than exactly single space was between the two values + lassign $value_posns p1 p2 + if {$p2 != $p1 +2} { + #sanity check + #can probably only get here through manual manipulation of the tomlish list to an unprocessable form + error "tomlish KEY appears to have more than one part - but not separated by whitespace - invalid '$keyval_element'" + } + set between_token [lindex $sublist $p1+1] + if {[lindex $between_token 1] ne " "} { + error "tomlish KEY in 2 parts is not separated by a single space - cannot consider for datetime '$keyval_element'" + } + lassign [lindex $values 0] type_d1 value_d1 + lassign [lindex $values 1] type_d2 value_d2 + if {$type_d1 ne "DATETIME" || $type_d2 ne "DATETIME"} { + error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" + } + set type DATETIME + set value "${value_d1}T${value_d2}" + } + default { + error "tomlish Found multiple value elements in KEY, expected one. (or 2 for space-separated datetime) '$keyval_element'" + } + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [ list [lindex $values 0] ]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole [lindex $values 0] (type val) - not just the $value! + set prev_tablenames_info $tablenames_info + set tablenames_info [dict create] + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + set tablenames_info $prev_tablenames_info + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + package require dictn + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + + #Declaring, Creating, and Defining Tables + #https://github.com/toml-lang/toml/issues/795 + #(update - only Creating and Defining are relevant terminology) + + #review + #tablenames_info keys type created, defined, createdby, definedby, closedby ??? review keys + # [tname] = header_table [[tname]] = header_tablearray + + #consider the following 2 which are legal: + #[table] #'table' created, defined=open type header_table + #x.y = 3 + #[table.x.z] #'table' defined=closed closedby={header_table table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k= 22 + # #'table.x.z' defined=closed closedby={eof eof} + + #equivalent datastructure + + #[table] #'table' created, defined=open definedby={header_table table} + #[table.x] #'table' defined=closed closedby={header_table table.x}, 'table.x' created defined=open definedby={header_table table.x} + #y = 3 + #[table.x.z] #'table.x' defined=closed closedby={header_table table.x.z}, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k=22 + + #illegal + #[table] #'table' created and defined=open + #x.y = 3 #'table.x' created first keyval pair defined=open definedby={keyval x.y = 3} + #[table.x.y.z] #'table' defined=closed, 'table.x' closed because parent 'table' closed?, 'table.x.y' cannot be created + #k = 22 + # + ## - we would fail on encountering table.x.y because only table and table.x are effectively tables - but that table.x is closed should be detected (?) + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + + + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keyed on tablepath each of which is a list such as {config subgroup etc} (corresponding to config.subgroup.etc) + } + + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [tomlish::to_dict::get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #tleaf -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set tleaf [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set tleaf [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $tleaf]} { + error "Duplicate key '$table_hierarchy $tleaf'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + dictn incr tablenames_info [list $table_hierarchy seencount] + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + set t [list {*}$table_hierarchy $tleaf] + dictn incr tablenames_info [list $t seencount] + dictn set tablenames_info [list $t closed] 1 + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } + + } + TABLEARRAY { + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + + set NEST_DICT [dict create] ;#first blush attempt at referencing supertable tablearrays + set tablearrayname [lindex $item 1] + log::debug "---> to_dict processing item TABLENAME (name: $tablearrayname): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablearrayname true] ;#true to normalize + #we expect repeated tablearray entries - each adding a sub-object to the value, which is an array/list. + #tablearrayname is likely to appear multiple times - so unlike a TABLE we don't check for 'defined' for the full name as an indicator of a problem + set supertable [list] + ############## + # [[a.b.c.d]] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of tablearray name $tablearrayname already has data but doesn't appear to be a table - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_supertable_keycollision + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } else { + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #REVIEW!! + # what happens with from_toml {[[a.b.c]]} {[[a]]} ??? + dictn set tablenames_info [list $supertable type] header_table ;#how do we know it's not going to be a tablearray? + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } else { + #supertable has already been created - and maybe defined - but even if defined we can add subtables unless it is of type itable + #but if it's a tablearray - we need to point to the most 'recently defined table element of the array' + #(another way of saying last member of that array)?? + set supertype [dictn get $tablenames_info [list $supertable type]] + if {$supertype eq "header_tablearray"} { + puts stdout "todict!!! TABLEARRAY nesting required for supertable [join $supertable .]" + puts stdout "todict!!! todo.." + #how to do multilevel nesting?? + set EXISTING_SUPERARRAY_ELEMENTS [dict get $datastructure {*}$supertable value] + dict set NEST_DICT $supertable $EXISTING_SUPERARRAY_ELEMENTS + puts stdout "todict!!! supertable '[join $supertable .]' elements $EXISTING_SUPERARRAY_ELEMENTS" + } + } + } + # + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + #first encounter of this tablearrayname + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[[a]]} + set msg "Cannot create tablearray name $tablearrayname. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_direct_keycollision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no collision - we can create the tablearray and the array in the datastructure + dictn set tablenames_info [list $norm_segments type] header_tablearray + dict set datastructure {*}$norm_segments [list type ARRAY value {}] + set ARRAY_ELEMENTS [list] + } else { + #we have a table - but is it a tablearray? + set ttype [dictn get $tablenames_info [list $norm_segments type]] + #use a tabletype_unknown type for previous 'created' only tables? + if {$ttype ne "header_tablearray"} { + set msg "tablearray name $tablearrayname already appears to be already created as a table not a tablearray - invalid?" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #add to array + #error "add_to_array not implemented" + #{type ARRAY value } + set ARRAY_ELEMENTS [dict get $datastructure {*}$norm_segments value] + } + + + set object [dict create] ;#array context equivalent of 'datastructure' + set objectnames_info [dict create] ;#array contex equivalent of tablenames_info + + #add to ARRAY_ELEMENTS and write back in to datastructure. + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #MAINTENANCE: temp copy from TABLE + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + #set supertable $norm_segments + set supertable [list] ;#disconnect from main structure - each array element is a new context for key paths! + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey '$dottedkeyname' kv: $keyval_dict" + #dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #wrong + #TODO!!!!!!!!!!!!! + #lappend ARRAY_ELEMENTS [list $dottedkeyname $keyval_dict] + dict set object $dottedkeyname $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + TABLE { + #we should be able to process tablearray subtables either as part of the tablearray record, or independently. + #(or even a mixture of both, although that is somewhat an edge case) + #[[fruit]] + #x=1 + # [fruit.metadata] + # [fruit.otherdata] + + #when processing a dict destined for the above - the tomlish generator (e.g from_dict) + #should create as 1 or 3 records (but could create 2 records if there was an unrelated table in between the subtables) + #choices: all in tablearray record, tablearray + 1 or 2 table records. + # + #We are going the other way here - so we just need to realize the list of tables 'belonging' to this tablearray might not be complete. + # + #the subtable names must be prefixed with the tablearray - we should validate that for any contained TABLE records + + } + default { + error "Sub element of type '$type' not understood in tablearray context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #todo? + ##end of TABLE record - equivalent of EOF or next header - close off the dottedtables + #foreach dtablepath $dottedtables_defined { + # dictn set tablename_info [list $dtablepath defined] closed + #} + + if {[dict size $NEST_DICT]} { + puts "reintegrate?? $NEST_DICT" + #todo - more - what if multiple in hierarchy? + dict for {superpath existing_elements} $NEST_DICT { + #objects stored directly as dicts in ARRAY value + set lastd [lindex $existing_elements end] + #insufficient.. + #dict set lastd [lindex $norm_segments end] [list type ITABLE value $object] + dict set lastd [lindex $norm_segments end] $object + #set lastd [dict merge $lastd $object] + lset existing_elements end $lastd + dict set datastructure {*}$superpath [list type ARRAY value $existing_elements] + } + } else { + #lappend ARRAY_ELEMENTS [list type ITABLE value $object] + lappend ARRAY_ELEMENTS $object + dict set datastructure {*}$norm_segments [list type ARRAY value $ARRAY_ELEMENTS] + } + } + TABLE { + set tablename [lindex $item 1] + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + #As our TABLE record contains all it's child DOTTEDKEY records - this should be equivalent to setting them as defined at EOF or next header. + + log::debug "---> to_dict processing item TABLE (name: $tablename): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablename true] ;#true to normalize + + set T_DEFINED [dictn getdef $tablenames_info [list $norm_segments defined] NULL] + if {$T_DEFINED ne "NULL"} { + #our tablename e.g [a.b.c.d] declares a space to 'define' subkeys - but there has already been a definition space for this path + set msg "Table name $tablename has already been directly defined in the toml data. Invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + + + set name_segments [::tomlish::to_dict::tablename_split $tablename 0] ;#unnormalized e.g ['a'."b".c.d] -> 'a' "b" c d + #results of tablename_split 0 are 'raw' - ie some segments may be enclosed in single or double quotes. + + + set supertable [list] + ############## + # [a.b.c.d] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of table name $tablename already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] header_table + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } else { + #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable + + } + } + #table [a.b.c.d] hasn't been defined - but may have been 'created' already by a longer tablename + # - or may have existing data from a keyval + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[a]} + set msg "Cannot create table name $tablename. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablename_keyval_collision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no data or previously created table + dictn set tablenames_info [list $norm_segments type] header_table + + #We are 'defining' this table's keys and values here (even if empty) + dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here + } + dictn set tablenames_info [list $norm_segments defined] open + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> normalized table key hierarchy : $norm_segments" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + set supertable $norm_segments + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey $dottedkeyname kv: $keyval_dict" + dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #end of TABLE record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dictn set tablename_info [list $dtablepath defined] closed + } + + + #review??? + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + #take a raw string and classify: result is a 2 element list comprised of KEY|SQKEY|DQKEY and the value being the appropriate inner string + proc _from_dict_classify_key {rawval} { + if {![::tomlish::utils::is_barekey $rawval]} { + #requires quoting + # + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + # + #we'll use a basic mechanisms for now to determine the type of quoting + # - whether it has any single quotes or not. + # (can't go in an SQKEY) + # - whether it has any chars that require quoting when in a Bstring + # (if so - then its visual representation might be unsuitable for a key in a toml text file, so escape and put in DQKEY instead of literal SQKEY) + #todo - more? + #REVIEW - the backslash might often be in things like a regex or windows path - which is often better expressed in a literal SQKEY + # from literal examples: + # 'c:\Users\nodejs\templates' + # '<\i\c*\s*>' + #If these are in *keys* our basic test will express these as: + # "c:\\Users\\nodejs\\templates" + # "<\\i\\c*\\s*>" + # This still works - but a smarter test might determine when SQKEY is the better form? + #when coming from external systems - can we even know if the value was already escaped? REVIEW + #Probably when coming from json - we know it's already escaped - and so we build our dict converting keys to unescaped + #TODO - clarify in documentation that keys resulting from to_dict are in 'normalized' (unescaped) form + # + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + set k_escaped [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + if {[string length $k_escaped] != [string length $rawval]} { + #escaping made a difference + set has_escape_requirement 1 + } else { + set has_escape_requirement 0 + } + if {[string first ' $rawval] >=0 || $has_escape_requirement} { + #basic string + # (any ANSI SGR sequence will end up here in escaped form ) + return [list DQKEY $k_escaped] + } else { + #literal string + return [list SQKEY $rawval] + } + } else { + return [list KEY $rawval] + } + } + + #the quoting implies the necessary escaping for DQKEYs + proc _from_dict_join_and_quote_raw_keys {rawkeylist} { + set result "" + foreach rk $rawkeylist { + lassign [_from_dict_classify_key $rk] type val + switch -- $type { + SQKEY { + append result "'$val'." + } + DQKEY { + append result "\"$val\"." + } + KEY { + append result "$val." + } + } + } + return [string range $result 0 end-1] + } + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + set K_PART [_from_dict_classify_key $k] ;#get [list SQKEY ] + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + set result [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + #(SQKEY & DQKEY do not have the enclosing quotes in their returned val) + #if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + # set VK_PART [list SQKEY $vk] + #} else { + # set VK_PART [list KEY $vk] + #} + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + #REVIEW - we could detect if value is an array of objects, + #and depending on parent context - emit a series of TABLEARRAY records instead of a DOTTEDKEY record containing an ARRAY of objects + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + + #we can't just join normalized keys - need keys with appropriate quotes and escapes + #set tname [join [list {*}$keys $vk] .] ;#WRONG + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list $K_PART] = ITABLE {NEWLINE lf} + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + lappend result TABLE $tname {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list $VK_PART] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + #review - where to make decision on + # DOTTEDKEY containing array of objs + #vs + # list of TABLEARRAY records + #At least for the top + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + error todo + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like tentative_accum_squote need to do their own append + switch -exact -- $tokenType { + tentative_accum_squote { + #should only apply within a multiliteral + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-squote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-squote-space { + } + default { + error "--- unexpected popped due to tentative_accum_squote but came from state '$prevstate' should have been trailing-squote-space" + } + } + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type single_squote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + MULTILITERAL { + #empty + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + ''''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "''"] + } + MULTILITERAL { + lappend v($parentlevel) [list LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + } + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + tentative_accum_dquote { + #should only apply within a multistring + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the trailing-dquote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-dquote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-dquote-space { + } + default { + error "--- unexpected popped due to tentative_accum_dquote but came from state '$prevstate' should have been trailing-dquote-space" + } + } + switch -- $tok { + {"} { + tomlish::parse::set_token_waiting type single_dquote value $tok complete 1 startindex [expr {$i -1}] + } + {""} { + #review - we should perhaps return double_dquote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_dquote value "" complete 1 startindex [expr {$i - 2}] + } + {"""} { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 3}] + } + {""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left dquote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {"}] + } + MULTISTRING { + #empty + lappend v($parentlevel) [list STRINGPART {"}] + } + default { + error "--- don't know how to integrate extra trailing dquote with data $v($parentlevel)" + } + } + } + {"""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 dquotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {""}] + } + MULTISTRING { + lappend v($parentlevel) [list STRINGPART {""}] + } + default { + error "--- don't know how to integrate extra trailing 2 dquotes with data $v($parentlevel)" + } + } + } + } + } + triple_dquote { + #presumably popping multistring-space + ::tomlish::log::debug "---- triple_dquote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTISTRING { + lappend merged $part + } + STRINGPART { + if {$lasttype eq "STRINGPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + CONT - WS { + lappend merged $part + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_dquote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g tentative_accum_squote does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + tentative_trigger_squote - tentative_trigger_dquote { + #### this startok will always be tentative_accum_squote/tentative_accum_dquote starting with one accumulated squote/dquote + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + single_squote { + #JMN - REVIEW + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERALPART + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + triple_dquote { + set v($nest) [list MULTISTRING] ;#container for NEWLINE,STRINGPART,CONT + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + tablename { + #note: we do not use the output of tomlish::to_dict::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names from + # a structural perspective. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$trimtable'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablearrayname: '$trimtable'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + #puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + #puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + single_dquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + dquoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + multistring-space { + lappend v($nest) [list STRINGPART {"}] + #may need to be joined on pop if there are neighbouring STRINGPARTS + } + default { + error "---- single_dquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_dquote { + #leading extra quotes - test: toml_multistring_startquote2 + switch -exact -- $prevstate { + itable-keyval-value-expected - keyval-value-expected { + puts stderr "tomlish::decode::toml double_dquote TEST" + #empty string + lappend v($nest) [list STRINGPART ""] + } + multistring-space { + #multistring-space to multistring-space + lappend v($nest) [list STRINGPART {""}] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + + } + single_squote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from tentative_accum_squote pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- single_squote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + enddquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + untyped_value { + #would be better termed unclassified_value + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + unset -nocomplain tag + if {$tok in {true false}} { + set tag BOOL + } else { + if {[::tomlish::utils::is_int $tok]} { + set tag INT + } else { + if {[string is integer -strict $tok]} { + #didn't qualify as a toml int - but still an int + #probably means is_int is limiting size and not accepting bigints (configurable?) + #or it didn't qualify due to more than 1 leading zero + #or other integer format issue such as repeated underscores + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. (looks close to being an int. Formatting or range issue?) [tomlish::parse::report_line] (no space level change)" + } else { + if {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok] || [::tomlish::utils::is_timepart $tok]} { + #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a localdate + #e.g x= 2025-01-01 02:34Z + #The to_dict validation will catch an invalid standaline timepart, or combine with leading date if applicable. + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + } + } + } + #assert either tag is set, or we errored out. + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [dict create] + dict set Bstring_control_map \b {\b} + dict set Bstring_control_map \n {\n} + dict set Bstring_control_map \r {\r} + dict set Bstring_control_map \" {\"} + dict set Bstring_control_map \x1b {\e} ;#In spec it's included in the list of 'must be escaped', as well as the 'convenience' escapes - so we make it go both ways. + dict set Bstring_control_map \\ "\\\\" + + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + #8 = \b - already in list. + #built the remainder whilst checking for entries already hardcoded above -in case more are added to the hardcoded list + for {set cdec 0} {$cdec <= 7} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + # \u007F = 127 + dict set Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + #plus \e for \x1b? + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + append buffer {"} + } + b - t - n - f - r { + append buffer [subst -nocommand -novariable "\\$c"] + } + e { + append buffer \x1b + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\$c" + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] ;#0b101 etc covered by a-f + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + #(but still allowing 0 -0 +0) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. (excludes also +++1 etc) + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + + #------------------------------------------- + #unclear if a 'digit' includes the type specifiers x b o + #we assume the 0x 0b 0o are NOT counted as digits - as underscores here would seem + #to be likely to cause interop issues with other systems + #(e.g tcl allows 0b1_1 but not 0b_11) + #Most of this structure would be unnecessary if we could rely on string::is::integer understanding underscores (9+?) + #we still need to support earlier Tcl for now though. + + #first rule out any case with more than one underscore in a row + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_0xFF + if {[string index $utest 0] eq "_"} { + return 0 + } + if {[string range $utest 0 1] in {0x 0b 0o}} { + set testnum [string range $utest 2 end] + } else { + set testnum $utest + #exclude also things like 0_x 0___b that snuck past our prefix test + if {![string is digit -strict [string map {_ ""} $testnum]]} { + return 0 + } + #assert - only digits and underscores in testnum + #still may have underscores at each end + } + #assert testnum is now the 'digits' portion of a , 0x 0b 0o number + #(+ and - already stripped) + #It may still have chars unsuitable for its type - which will be caught by the string::is::integer test below + if {[string length $testnum] != [string length [string trim $testnum _]]} { + #had non-inner underscores in 'digit' part + return 0 + } + #assert str only has solo inner underscores (if any) between 'digits' + #------------------------------------------- + + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + + + + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements by default (for now) + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + #some question around implementations allowed to use lower values such as 2^31 on some systems? + if {$::tomlish::max_int ne "" && $numeric_value > $::tomlish::max_int} { + return 0 + } + if {$::tomlish::min_int ne "" && $numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + #note - Tcl's string is double will return true also for the subset of float values which are integers + #This function is to determine whether it matches the Toml float concept - so requires a . or e or E + proc is_float {str} { + #vip greenlight known literals, don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + #doorcheck the basics for floatiness vs members of that rival gang - ints + if {![regexp {[.eE]} $str]} { + #could be an integer - which isn't specifically a float for Toml purposes. + return 0 + } + + + #patdown for any contraband chars + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + + #all characters in legal range + + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + + #Early Toml spec also disallowed leading zeros in the exponent part(?) + #... this seems less interoperable anyway (some libraries generate leading zeroes in exponents) + #we allow leading zeros in exponents here. + + #Check for leading zeros in main part + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #----------------------------------------- + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_" || [string index $str end] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_ + if {[string index $utest 0] eq "_"} { + return 0 + } + #----------------------------------------- + + #decimal point, if used must be surrounded by at least one digit on each side + #e.g 3.e+20 also illegal + set dposn [string first . $str] + if {$dposn > -1 } { + set d3 [string range $str $dposn-1 $dposn+1] + if {![string is integer -strict [string index $d3 0]] || ![string is integer -strict [string index $d3 2]]} { + return 0 + } + } + #we've already eliminated leading/trailing underscores + #now ensure each inner underscore is surrounded by digits + if {[regexp {_[^0-9]|[^0-9]_} $str]} { + return 0 + } + + #strip underscores for tcl double check so we can support < tcl 9 versions which didn't allow underscores + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + #All good - seems to be a toml-approved float and not an int. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_datepart {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_localdate {str} { + is_datepart $str + } + proc is_timepart {str} { + set numchars [tcl::string::length $str] + #timepart can have negative or positive offsets so - and + must be accepted + if {[regexp -all {[zZt0-9\-\+\.:]} $str] == $numchars} { + #todo + #basic check that we have leading 2dig hr and 2dig min separated by colon + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}[^0-9]{1}.*$} $str]} { + #nn:nn or nn:nnX.* where X is non digit + return 0 + } + return 1 + } else { + return 0 + } + } + proc is_localtime {str} { + #time of day without any relation to a specific day or any offset or timezone + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\.:]} $str] == $numchars} { + #todo + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}:[0-9]{2}([.][0-9]*){0,1}$} $str]} { + #hh:mm or hh:mm:ss or hh:mm::ss.nnn + return 0 + } + return 1 + } else { + return 0 + } + } + + #review + proc is_datetime {str} { + #Essentially RFC3339 formatted date-time - but: + #1) allowing seconds to be omitted (:00 assumed) + #2) T may be replaced with a single space character TODO - parser support for space in datetime! + # (RFC 3339 allows space instead of T also - but doesn't specify it *must* be a single space) + + #toml-lint @2025-04 doesn't accept t for T or z for Z - but RFC3339 does + #toml spec doesn't clarify - we will accept + + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 not ok - 2024T not accepted by tomlint why? + # 02:00 ok + # 02:00:00.5 ok + # 1:00 - not ok - RFC3339 requires 2-digit hr,min,sec + + #toml-lint.com accepts 2025-01 + + if {[string length $str] < 5} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\ \-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + if {[regexp -all {\ } $str] > 1} { + #only a single space is allowed. + return 0 + } + #If we get a space - it is only valid as a convience to represent the T separator + #we can normalize by converting to T here before more tests + set str [string map {" " T t T} $str] + #a further sanity check on T + if {[regexp -all {T} $str] > 1} { + return 0 + } + + #!todo - use full RFC 3339 parser? + #!todo - what if the value is 'time only'? + + if {[string first T $str] > -1} { + lassign [split $str T] datepart timepart + if {![is_datepart $datepart]} { + return 0 + } + if {![is_timepart $timepart]} { + return 0 + } + } else { + #either a datepart or a localtime + #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day + # without any relation to a specific day or any offset or timezone." + if {!([is_datepart $str] || [is_localtime $str])} { + return 0 + } + } + + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # array-value-expected,keyval-value-expected,itable-keyval-value-expected, keyval-syntax, + # dquoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # xxx_value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + #--------------------------------------------------------- + #WARNING + #The stateMatrix implementation here is currently messy. + #The code is a mixture of declarative via the stateMatrix and imperative via switch statements during PUSH/POP/SAMESPACE transitions. + #This means the state behaviour has to be reasoned about by looking at both in conjuction. + #--------------------------------------------------------- + + #xxx-space vs xxx-syntax inadequately documented - TODO + + #review - out of date? + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> keyval-value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXsingle_dquote "quoted-key"\ + XXXsingle_squote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + enddquote "err-state"\ + endsquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-untyped-sequence" note "possible datetime datepart"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"} + + #untyped_value sequences without intervening comma are allowed for datepart timepart + #we will produce tomlish with missing SEPS and to_dict must validate whether 2 adjacent barekeys are valid + dict set stateMatrix\ + keyval-untyped-sequence {\ + whitespace "keyval-untyped-sequence"\ + untyped_value {TOSTATE "keyval-tail"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + #2025 - no leading-squote-space - only trailing-squote-space. + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + + #itable-space/ curly-syntax : itables + # x={y=1,} + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #we don't get single_squote etc here - instead we get the resulting squotedkey token + + + # ??? review - something like this + # + # x={y =1,} + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace {TOSTATE "itable-keyval-syntax"}\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal {TOSTATE "itable-keyval-value-expected"}\ + newline "err-state"\ + eof "err-state"\ + } + + # x={y=1} + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + single_dquote {TOSTATE "string-state" returnstate itable-val-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + single_squote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + #double_squote not currently generated by _start_squote_sequence - '' processed as single_squote to literal-state just like 'xxx' + # review + # double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"} + + + + # x={y=1,z="x"} + #POPSPACE is transition from itable-keyval-space to parent itable-space + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + newline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + comment "itable-val-tail"\ + eof "err-state"\ + } + # XXXnewline "POPSPACE" + # We shouldn't popspace on newline - as if there was no comma we need to stay in itable-val-tail + # This means the newline and subsequent whitespace, comments etc become part of the preceeding dottedkey record + #e.g + # x = { + # j=1 + # #comment within dottedkey j record + # , # comment unattached + # #comment unattached + # k=2 , #comment unattached + # l=3 #comment within l record + # , m=4 + # #comment associated with m record + # + # #still associated with m record + # } + ## - This doesn't quite correspond to what a user might expect - but seems like a consistent mechanism. + #The awkwardness is because there is no way to put in a comment that doesn't consume a trailing comma + #so we cant do: j= 1 #comment for j1 , + # and have the trailing comma recognised. + # + # To associate: j= 1, #comment for j1 + # we would need some extra processing . (not popping until next key ? extra state itable-sep-tail?) REVIEW - worth doing? + # + # The same issue occurs with multiline arrays. The most natural assumption is that a comment on same line after a comma + # is 'associated' with the previous entry. + # + # These comment issues are independent of the data dictionary being generated for conversion to json etc - as the comments don't carry through anyway, + # but are a potential oddity for manipulating the intermediate tomlish structure whilst attempting to preserve 'associated' comments + # (e.g reordering records within an itable) + #The user's intention for 'associated' isn't always clear and the specs don't really guide on this. + + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + eof "err-state"\ + newline "err-state"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - multiline itables appear to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + #dict set stateMatrix\ + # array-space {\ + # whitespace "array-space"\ + # newline "array-space"\ + # untyped_value "SAMESPACE"\ + # startarray {PUSHSPACE "array-space"}\ + # endarray "POPSPACE"\ + # startinlinetable {PUSHSPACE itable-space}\ + # single_dquote "string-state"\ + # single_squote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + # comma "array-space"\ + # comment "array-space"\ + # eof "err-state-array-space-got-eof"\ + # } + + ## array-space ## + set aspace [dict create] + dict set aspace whitespace "array-space" + dict set aspace newline "array-space" + #dict set aspace untyped_value "SAMESPACE" + dict set aspace untyped_value "array-syntax" + dict set aspace startarray {PUSHSPACE "array-space"} + dict set aspace endarray "POPSPACE" + dict set aspace single_dquote {TOSTATE "string-state" returnstate array-syntax} + dict set aspace triple_dquote {PUSHSPACE "multistring-space" returnstate array-syntax} + dict set aspace single_squote {TOSTATE "literal-state" returnstate array-syntax} + dict set aspace triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax} + dict set aspace startinlinetable {PUSHSPACE itable-space} + #dict set aspace comma "array-space" + dict set aspace comment "array-space" + dict set aspace eof "err-state-array-space-got-eof" + dict set stateMatrix array-space $aspace + + #when we pop from an inner array we get to array-syntax + #e.g {x=[[]] ??? + set tarntail [dict create] + dict set tarntail whitespace "tablearrayname-tail" + dict set tarntail newline "err-state" + dict set tarntail comment "err-state" + dict set tarntail eof "err-state" + dict set tarntail endtablename "tablearray-tail" + dict set stateMatrix tablearrayname-tail $tarntail + + #review - somewhat counterintuitive...? + # [(starttablearrayname) (endtablearrayname] + # [(starttablename) (endtablename)] + + # [[xxx]] ??? + set tartail [dict create] + dict set tartail whitespace "tablearray-tail" + dict set tartail newline "table-space" + dict set tartail comment "tablearray-tail" + dict set tartail eof "end-state" + dict set stateMatrix tablearray-tail $tartail + + + + + + + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #use dict set to add values so we can easily add/remove/comment lines + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions [dict create] + dict set spacePushTransitions keyval-space keyval-syntax + dict set spacePushTransitions itable-keyval-space itable-keyval-syntax + dict set spacePushTransitions array-space array-space + dict set spacePushTransitions table-space tablename-state + #dict set spacePushTransitions #itable-space itable-space + + #Pop to, next + variable spacePopTransitions [dict create] + dict set spacePopTransitions array-space array-syntax + + + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from keyval-value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions [dict create] + #JMN test + #dict set spaceSameTransitions array-space array-syntax + + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + set popfromspace_info [spacestack peek] + set popfromspace_state [dict get $popfromspace_info state] + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + ::tomlish::log::debug "--->> zeropoppushspace goNextState RECURSE. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + #for multiliteral, multistring - data and/or end + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo token beginning with underscore - never returned to state machine - review + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\{" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename - tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow: + # table -> starttablearrayname + # tablearray -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + array-syntax - array-space { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-tail { + #[[xxx] + set_tokenType "endtablename" + #sequence: starttablename -> starttablearrayname -> endtablearrayname -> endtablename + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + string - dquotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + #for within multiliteral + #short tentative_accum_squote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_squote is multisquote + 2 = 5 + #return tok with value ''''' + return 1 + } + } + tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multiliteral + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + #if there are more than 3 leading squotes we also enter multiliteral space and the subsequent ones are handled + #by the tentative_accum_squote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 squotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to a tentative_accum_squote token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #barekeys now support all sorts of unicode letter/number chars for other cultures + #but not punctuation - not even for those of Irish heritage who don't object + #to the anglicised form of some names. + # o'shenanigan seems to not be a legal barekey + #The Irish will have to use an earlier form Ó - which apparently many may prefer anyway. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading squote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_squote token or triple_squote token + #It currently doesn't trigger double_squote token + #(handle '' same as 'x' ie produce a single_squote and go into processing literal) + #review - producing double_squote for empty literal may be slightly more efficient. + #This token is not used to handle squote sequences *within* a multiliteral + set_tokenType "_start_squote_sequence" + set tok "'" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_squote" ;#trigger tentative_accum_squote + set tok "'" + return 1 + } + table-space - itable-space { + #tests: squotedkey.test squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXtable-space - XXXitable-space { + #future - could there be multiline keys? MLLKEY, MLBKEY ? + #this would (almost) allow arbitrary tcl dicts to be stored in toml (aside from escaping issues) + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + #@2025 ABNF for toml mentions key, simple-key, unquoted-key, quoted-key and dotted-key + #where key is simple-key or dotted-key - no MLL or MLB components + #the spec states solution for arbitrary binary data is application specific involving encodings + #such as hex, base64 + set_tokenType "_start_squote_sequence" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType "tablename" + append tok "'" + } + tablearrayname-state { + set_tokenType "tablearrayname" + append tok "'" + } + literal-state { + #shouldn't get here? review + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType "literal" + incr -1 + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + #error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + dottedkey-space { + set_tokenType "squotedkey" + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + tentative_accum_dquote { + #within multistring + #short tentative_accum_dquote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_dquote is multidquote + 2 = 5 + #return tok with value """"" + return 1 + } + } + _start_dquote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multistring + #switch? + append tok $c + set_tokenType triple_dquote + return 1 + } + default { + #if there are more than 3 leading dquotes we also enter multistring space and the subsequent ones are handled + #by the tentative_accum_dquote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 dquotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_dquote_sequence'" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + incr i -1 ;#throw the {"} back to loop - will be added to a tentative_accum_dquote token for later processing + return 1 + } + } + whitespace { + #assert: had_slash will only ever be true in multistring-space + if {$had_slash} { + incr i -2 + return 1 + } else { + #end whitespace token - throw dq back for reprocessing + incr i -1 + return 1 + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type enddquote value {"} complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading dquote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_dquote token or triple_dquote token + #It currently doesn't trigger double_dquote token + #(handle "" same as "x" ie produce a single_dquote and go into processing string) + #review - producing double_dquote for empty string may be slightly more efficient. + #This token is not used to handle dquote sequences once *within* a multistring + set_tokenType "_start_dquote_sequence" + set tok {"} + } + multistring-space { + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + } else { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_dquote" ;#trigger tentative_accum_dquote + set tok {"} + return 1 + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + default { + error "tomlish Unexpected dquote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0 + append tok $c + } + string - comment - dquotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok = + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + #multiliteral or multistring + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + #review + if {$had_slash} { + incr i -2 + } else { + incr i -1 + } + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $c + } + string - dquotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART xxx WS " " + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + append tok $c + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #assert - tok will be one or two squotes only + #A toml literal probably isn't allowed to contain this + #but we will parse and let the validator sort it out. + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart { + append tok $c + } + string - stringpart { + append tok $c + } + default { + #state machine will generally not have entry to accept bom - let it crash + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + multistring-space { + set_tokenType "stringpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + set tok \\$c + } else { + set tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "literal" + set tok "" + return 1 + + ##review + #set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + #set_tokenType "literal" + #set tok "" + #return 1 + } + } + } + _start_dquote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open string + error "tomlish eof reached without closing double quote for string. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "string" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + + proc _show_tablenames {tablenames_info} { + append msg \n "tablenames_info:" \n + dict for {tkey tinfo} $tablenames_info { + append msg " " "table: $tkey" \n + dict for {field finfo} $tinfo { + append msg " " "$field $finfo" \n + } + } + return $msg + } +} +tcl::namespace::eval tomlish::to_dict { + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "preval" ;#5 modes: preval, quoted,litquoted, unquoted, postval + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + #todo - track\count backslashes properly + + set c [tcl::string::index $tablename $i] + if {$c eq "\""} { + if {($lastChar eq "\\")} { + #not strictly correct - we could have had an even number prior-backslash sequence + #the toml spec would have us error out immediately on bsl in bad location - but we're + #trying to parse to unvalidated tomlish + set ctest escq + } else { + set ctest dq + } + } else { + set ctest [string map [list " " sp \t tab] $c] + } + + switch -- $ctest { + . { + switch -exact -- $mode { + preval { + error "tablename_split. dot not allowed - expecting a value" + } + unquoted { + #dot marks end of segment. + if {![tomlish::utils::is_barekey $seg]} { + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + set seg "" + set mode "preval" + } + quoted { + append seg $c + } + litquoted { + append seg $c + } + postval { + #got dot in an expected location + set mode "preval" + } + } + } + dq { + #unescaped dquote + switch -- $mode { + preval { + set mode "quoted" + set seg "\"" + } + unquoted { + #invalid in barekey - but we are after structure only + append seg $c + } + quoted { + append seg $c + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" ;#make sure we only accept a dot or end-of-data now. + } + litquoted { + append seg $c + } + postval { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } + } + ' { + switch -- $mode { + preval { + append seg $c + set mode "litquoted" + } + unquoted { + #single quote inside e.g o'neill - ultimately invalid - but we pass through here. + append seg $c + } + quoted { + append seg $c + } + litquoted { + append seg $c + #no normalization to do aside from stripping squotes + if {$normalize} { + lappend segments [tcl::string::range $seg 1 end-1] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" + } + postval { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + } + } + sp - tab { + switch -- $mode { + preval - postval { + #ignore + } + unquoted { + #terminates a barekey + lappend segments $seg + set seg "" + set mode "postval" + } + default { + #append to quoted or litquoted + append seg $c + } + } + } + default { + switch -- $mode { + preval { + set mode unquoted + append seg $c + } + postval { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + default { + append seg $c + } + } + } + } + + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + switch -exact -- $mode { + preval { + error "tablename_split. Expected a value after last dot separator. tablename: '$tablename'" + } + unquoted { + if {![tomlish::utils::is_barekey $seg]} { + #e.g toml-test invalid/table/with-pound required to fail for invalid barekey + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + } + quoted { + error "tablename_split. Expected a trailing double quote. tablename: '$tablename'" + } + litquoted { + error "tablename_split. Expected a trailing single quote. tablename: '$tablename'" + } + postval { + #ok - segment already lappended + } + } + } + } + + #note - we must allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + + return $segments + } + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + proc get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish::to_dict::get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "tomlish::to_dict::get_dottedkey_info DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + +} + + +tcl::namespace::eval tomlish::app { + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + tcl::namespace::eval argdoc { + proc test_suites {} { + if {[package provide test::tomlish] eq ""} { + return [list] + } + return [test::tomlish::SUITES] + } + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::decoder + @cmd -name tomlish::app::decoder -help\ + "Read toml on stdin until EOF + on error - returns non-zero exit code and writes error to + the errorchannel. + on success - returns zero exit code and writes JSON encoding + of the data to the outputchannel. + This decoder is intended to be compatble with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help\ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc decoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::decoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::decoder] + } + + #fconfigure stdin -encoding utf-8 + fconfigure $ch_input -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts $ch_error "decoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $j + exit 0 + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::encoder + @cmd -name tomlish::app::encoder -help\ + "Read JSON on input until EOF + return non-zero exitcode if JSON data cannot be converted to + a valid TOML representation. + return zero exitcode and TOML data on output if JSON data can + be converted. + This encoder is intended to be compatible with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help \ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc encoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::encoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::encoder] + } + #review + fconfigure $ch_input -translation binary + if {[catch { + set json [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts $ch_error "encoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $toml + exit 0 + } + + punk::args::define { + @dynamic + @id -id ::tomlish::app::test + @cmd -name tomlish::app::test + @leaders + @opts -any 1 + -help -type none -help\ + "Display this usage message + or further info if more args." + -suite -default tests -choices {${[::tomlish::app::argdoc::test_suites]}} + @values -min 0 -max -1 + } + proc test {args} { + package require test::tomlish + set argd [punk::args::parse $args withid ::tomlish::app::test] + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + set solos [dict get $argd solos] + set opt_suite [dict get $opts -suite] + if {[dict exists $received -help] && ![dict exists $received -suite]} { + return [punk::args::usage -scheme info ::tomlish::app::test] + } + + test::tomlish::SUITE $opt_suite + #if {[catch {test::tomlish::SUITE $opt_suite} errM]} { + # puts stderr "Unknown test suite '$opt_suite'. Available suites: [test::tomlish::SUITES]" + # exit 1 + #} + set run_opts [dict remove $opts -suite] + set run_opts [dict remove $run_opts {*}$solos] + set result [test::tomlish::RUN {*}$run_opts {*}$solos {*}$values] + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {[info exists ::argc] && $::argc > 0} { + #puts stderr "argc: $::argc args: $::argv" + set arglist $::argv + # -------------- + #make sure any dependant packages that are sourced don't get any commandline args + set ::argv {} + set ::argc 0 + # -------------- + package require punk::args + punk::args::define { + @dynamic + @id -id tomlish::cmdline + @cmd -name tomlish -help\ + "toml encoder/decoder written in Tcl" + @opts -any 1 + -help -type none -help\ + "Display this usage message or more specific + help if further arguments provided." + -app -choices {${[tomlish::appnames]}} + } + try { + set argd [punk::args::parse $arglist withid tomlish::cmdline] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + puts stderr $msg + exit 1 + } + + + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received -help] && ![dict exists $received -app]} { + #only emit cmdline help if -app not supplied as well - otherwise app function can act on -help for more specific help + #puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + puts stdout [punk::args::usage -scheme info tomlish::cmdline] + exit 0 + } + if {![dict exists $received -app]} { + puts stderr [punk::args::usage -scheme error tomlish::cmdline] + exit 1 + } + + set app [dict get $opts -app] + set appnames [tomlish::appnames] + set app_opts [dict remove $opts -app {*}$solos] + try { + set result [tomlish::app::$app {*}$app_opts {*}$solos {*}$values] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + #The validation error should fully describe the issue + #no need for errortrace - keep the output cleaner + puts stderr $msg + exit 1 + } trap {} {msg erroropts} { + #unexpected error - uncaught throw will produce error trace + #todo - a support msg? Otherwise we may as well just leave off this trap. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + if {"-help" in $solos} { + puts stderr $result + exit 1 + } else { + if {$result ne ""} { + puts stdout $result + exit 0 + } + } + + #set opts [dict create] + #set opts [dict merge $opts $::argv] + + #set opts_understood [list -app ] + #if {"-app" in [dict keys $opts]} { + # #Don't vet the remaining opts - as they are interpreted by each app + #} else { + # foreach key [dict keys $opts] { + # if {$key ni $opts_understood} { + # puts stderr "Option '$key' not understood" + # exit 1 + # } + # } + #} + #if {[dict exists $opts -app]} { + # set app [dict get $opts -app] + # set appnames [tomlish::appnames] + # if {$app ni $appnames} { + # puts stderr "app '[dict get $opts -app]' not found. Available apps: $appnames" + # exit 1 + # } + # tomlish::app::$app {*}$opts + #} +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.5 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.2.tm new file mode 100644 index 0000000000000000000000000000000000000000..e69038aff2079adfcfb92e7cb382dbe03c205aac GIT binary patch literal 11871 zcmch6c|4Tg+rPC?C|R-EkG95*|Up`k`@wkS`wIM-1`2jUA}B~tD41$YJb~nmz+r>XkP{YP3rcVJOqU=$kI&l`(J!_s`gGa`cGsQ^h631l)BUPDG; z(7-xi6%hh%qmZyj3NRg6Peydfp`lBD!AgkF;e*gVkf^o zB?52=U`Y==F9}K0 z?oay^7YhM#zXU-jgvOE4D}$5A=gG7(pbG2t*PVBn~cc ziFi0z!8;@^#>i+S1q#-O3|5M1cq!E$I2;=90V<5Rz6+$I11W*UBs9gBgolDdmpU8X z0)LinGx%R`(}kQC9sVbf@QHBTz-3Ncf0?@QYxn~%(TBth{<^>b5(i>dT(YvN^9Kj7 z{2D_bp%I|A1OQ}EFuYh=JV54;hFi4UV1*cFi@0BwP0 zr+^i8gqN+X$jVRW;$TIaE#CpFk3%BJXg69Vb|a%bywP}2oSfiFhxY&_5=Zb~Nc&$Y z3{uI(Wf|gM@@Ul*E~aEyh2`=nNSu}y#T)J$WXcMn<_(WSx_QH5AaNSd#e$cYefTIC z1a-?IZKxGw4*k5u zf%gDyZ!vmW>2_I^hrgWxfrxT}wu||Kq6HTnGzky`*vBXc7Qf7Au+s3y9puHq72ht8 zo8?cIm`!|%9)C;&*ijf?9Bz)4Ku%r+Ktr661UzW}&{84Pz5)6(EZGIp(tjE+oO*8?<>cM9oc@ zr2!&JJm`@@-;kX6yMu6Nw7X)kxD=CMN{xNv9$nF4vh z4A>i{MBp2R#vua95Fq0ISUig0Plkv%1O-$+z`Ox_#S`%I)OLaZD#)yi%+?bo?_eWn zlD^)6)dqrY0))`4uc!zd0Ar&OSkN56bC4kj;7^J_fpm~ccbBq7*!1vcAv36U0UZGa zm@jk?4FEeW50F0>Q&B}lS}4IRi^pmc%X`q6A+GL?H!I z4M$noIxsS7=FHtxR`d?M2>ysIv)2Myh8C>zw>$>L4!+ExyZTX0wCe*^)8 zp<0bh0j2QQ6_gCFpSrrbi$Zsg>aAk)JzAw>(gg{aGA{cs* zKwe`(^#kP}gdMHuW3T}r0I5jeME?6h%jv~Dgg?Kb`E+rFFL&dLm&V^OfB(_LOH4rH z0MNX5sqTQQ{r~dtImZLf(M&~^2U?%gqMt5*H{OzB{rGh}Xj@@r0l0S$^8 zCi8b~csv9+7Dy555Qf^YX!HdVUqtHujCEyKhOS%%#6T^gnR*G`g2=w^;3fht%>I-aP-o)0x!a?cttzS z4Hf>EUS1~huPjjvgTUe30lkG23NHR2;pREiGD&cvh*=mYK=y!MP+1ES@OscaVN+09 zfHxWik0BsnH!>s-=8vG)fp@ex0ZayPYM2?2S9ZkmG=n1m9;_@B%fBWNynnv({>IN2 zl=?5rJ(Zx4Js{CvQ3{V+7sM=317J3qcJuKGzURXj^h@A#T6V!i0pSNKFLgLbo6r6> z<(scV^WSq9cy9m$QW-UVhH%)S)9Bl{C|X*rd*kQILBe z;E8x&;QP6`E|FSafvc!RZXxmDiw+LVoD}|?YB1X0klF${)M+soDMNr80TKaw9-KCp z9^j${QwAU%F+UWBN%pTO<#cz`vrR6T;&$W(CY3I#D4`0 z%lZFMzu{w6uHk=vv-0}iCbYm&v}?kDW!7b;SbE0NU-19XECf6VP*6;NjTQy0%ov%t z>FDTK=!|8f9R>SJel~BQqcgUoqf-D+=ljoG)v^V*K6xbtWd#+*WlunFysLeX{CaCa z_tX}vWBij^sX`euT@SJ`O+hE`jJ8X@j&ADYR53O@alA}@S3VQg>BZZUNzK&|Ya%4^ zAS)vd&9!aYBp+SedGbVVN5Z=q&l=qT#Kn(oF`;!i$P*rs$x)`-==C!bn$@irzeoNf znUIih(s+=Smu>JF{T3zblvr zEk-oo%U6SohTa~ z8X6kAz*Xj{{W`#h?cZ8HlRFlJAt#x3l?}01NsKGhd^}0H5Si^;Cx=RjtpA{t5KtOf z@3+}g<>A+Xph=ZgX&QpUL%5-BV`=x^m=hZVWvnJg17legXZ?{m5X*Cw|BkaJLnCc@clGv@4>wX-s=4b`w(U^ z#HhbZjEhCJC^@mei!yM&T=(9sfzcP4vSq3vF9KBHOUaC3sTh{M{P9dy0lcCKsDE}twmX}!Yr zfdhJC8RhcXytS$GIh!pX+p*ns$49p4uMXia7pb$Odn)m|_DR6`1I|ogY;{OGzs!BzfP-LK-pdS!TCIay zUkbQd-;9ZQFg9Lquc6U{V+}Z)IHAVw5{HxzdGGP`qc4Ls9b*lLc@L@k*?XnSBFNo&tiTvWAX{0;V4sIi-^VcE~ik)$G+x_{hyR-q;8zH7UeYAIr8 zQ(OD#vPb%+(1&aLV`@i_gnh-pN9x0K30#s}OXD(6E={9QINSf>q9j<1t(n97YE z+QqB7<-zU#r^QcnED!yw=^(tbB1hGFM<%yN=`j{FVOghU4{kf9mQKHk$doPqTS9uZ z3a%%M_tYO0zP&B_k|H9BG*EcGW0mHnf6X%e8sbp`G7f#Iha|amoZ}K3^2863jvx?6 zG`YTWAT_O?Z(>VTLRK;siB>gNSDI+0tE8Q?FwJ*nWe@v@h4JfnDZ$E6=N&?xHOYo^ zN<;0XzL8Rs)!>c5Q(f_&u67ibo9piA5_jlMm92=a&#o$1x7)3vGGcXHmd8M_RdKNR zrRxsU0s+&5xaN&)B)V&u1N>IAB8quxW$8-wXLmDRWRP$sR&5hJnRN(SjQyf>i7?_$}35|}Ehq+RWU4+%&8VIO2xkQx* zv-00Le##rE=9g-*)6Ko1FahQtl$PxPq~fzFPI^nEP_? zRk4yKJ2<}l=v*`1*D_T<*{z)0RN#{m81AiuLT$buG^k_Zsi7Cjz%J#+lJag}bXg29 zi-?<lvq&VJ_a>n|aseuFN-E=}r%J zynV@(ntYq5=q~nBqey0+3tjqYVb+v8Ba$gOZ$2@O#Ctz!+>^~IqgH-oeW7oUfXxHw z10+Mj49m1fWrsP3ePfO7AJ@zIC#YVxq~wdasgQJ<%ZI(l%I23}3=>7yw-oM(%(~oZ zkS`_ckfZSVdOUquz!~***%zATbZ;j6y1jnm~nA;306T!mzHEmea z$Rl)KNuB5IeKlTDeC-E(#JQ0;XIsNVHRHp6kB=Hr7!=kzi){TO#Xbq?1z zaFFA0I{a#yOWzv)7`+zbvpD+$>3-@RXoAD{`+2rfH`eCH zS^ta}ubUC@WRJnDi*k4NM5M{cD!vZLIyAGkOEm-_~%WQN%ZtC_*T*~dRj zq1`br*aYVYqwA#%^EWS=ln4}PH0kg-4MV%3e;ub)>x8y_DZ`!GHIkl@zYg=hJ3 z^U)4<43b|zp2vJ&vco;qb)OhQHt{Omn{a!R!6Y438t&98U~r3}We4Yv_KhiL;*CXH8Xoj*m~@_251mt2Vn3Z!cw( zqTxq1q_Dsq9{b=Mohq`75=I9Mh0{;=`N?!&xR~9Z^|mqhba1EoEMaGR?X6a;tlUlu z_1jRNYUPg|yIt(BJ`za0SN_naRCOuSM2Rw_UU=bZ<3{mG>d;s}~FJKBsi) zA?EqDLZWI%f%=ylDmQsY`%}kS2Ka}1XX~sgaQ9a$Y}P=Ev~I~#dR=<|pySIj_kxbf zP#v5$`mJ3>llVv3*%t^^t6K8w2Ir2M3W1$*UZhhO;}AU;5oLhIgJt%#j%1~7LY?P1U$5z|#8^iez zvNHu={nyP5zI( z?C3j9!}YBi$q&T@x2wG}u{nIt>r+>XWtybygjFtcLSjIq(RrzI)@{unKfZHSH;kq~ zsW4D$L}@v0hjI2z9yqV~+)XN#vwBjxqi-Kex>V9WL5*Wrjm|SA_ z@!k0-beJ`-vYn0>!Itg((gehGls5GKZqwFKgIU{?CpEXp#It|m8({f}6Sw_Dk=hq^ zzdy42k)T+srSE{T5v7?o3#pS@6yMGFA?;X~nV-T;L;tP!Uzo0bVsRa7lG-^}#VnHx zr;!;=u`%KdeUW#gq^f#$Z1gZqtkyfoo)~UQI6`0fNceH|h6>@dcWWk1Uu*S{8*DDy zoZFVm# z+r2fcPqKU4a!0a?XM~GAznph8c*?ae#4dMS;$fU6D&L}*iOev(Pg>{IC6U{_*1epw zs#=b9H#S!`9T_RBw$)sJkT@b4yZH&-rS)Ovw_n*+l_l?ZSnoDIJ024I$dq9}k(&)~ z*-*gd_tVpoH$uqp@r@RvvWdhkKIZ~+)CG<_#_&8$={l=vdq$hZMX$=)%q$tY(l~PL zWtTcmwzOK(``NaK-_!&s2I<8J&nDh`9GaKHqAC-PS^XxpCOxCB(NoAuXr(bIY_>BVVzZn*?W`$V|Y2 zDIUQ%F}^yq2G*8W_I3}~&_|4nO1LiTMGK!n&3boPM;S}&sQS!+r;W{WtF`P6ztCSc zI@SA}*4(AM2%3B9Cx)5#k(9r zUfa^WMm3WfY}(^$#sx0f_q5({b?c7*$`QtNQsYwN0j-9nB(3pXV`6Q0H}gMh^UCfH z_t_f7RrLu13I-b(~`-T&fQf zos^WdhYW07Z9SwQn;I^ba{+spOceGO83euQlhOZjUVH68vRZ3J21zEB+r@Re{@q81 zeV^tVP8&E1>q?tu?v_&)kp9PUu(_KhWbcItwxX7@B4oQs>F8l#3|(|-#gY7utoA0C zF3A+j9CGY1OCODhd!k1`eu zk&c|Re`6d@F12YqbV*T^aMMv;pDTIbI-9&QgUGG2$U=Jtmi`~fwLZ|XL3JLf-S4f) zp5xJM_q90NOL!Ve%QkuGX_Q|7+I!*rtM8KsJH|Rgf5wk$6mXEGeT9v+^)@tLuRAG3 z?8;~M9Njd`D8ayz`y}URcF4_=txcTozRiv_Js(Zb+p|xs$eq}(tnfh~!1Q`Dw{^H| zZqLZk8&fFeTR6oev(baHCM8w}48ms27|5LJF7Y3>7k8eGm_Gkx&(;QxX^)EA)~Yp3 zI}e^@H{jp0P6VTS!dOPnEw8fw%B!mT>sVchjIxsDO6~2BEc5q7w<+s9sv52|%?Tzl z3*4Iaa5Nqsc^36}ZDH>!&w;Lla8t?Y)pu@|b5=ZE{Z4wu`RQqsl-IhQ_gT**p+4Bf z6|r6AVHgpu+I-r1 zOaH`|S6j2<+p8bhNT$7r*m{|}1K-BjD#ds|@vOpAxJ7Kby-e>6f zXmYoup!S2@v)|eCl%`d69>m44Uv9Yi=v8iljsBjz^t(O68n${zTlAy0?(CkmO#bnO z)#=QR1SSt1{+Hh7vO$8`hRJujgV`;bZgx3HIlZU9S^MBDbHJv_jn7&>jP>oi=lmw? zl@sD~qs}YqI1A*g$8PQZPQ40#58Y|m7Ytjc+zuViVEeaPXzE*gcSgOgd2;8*_{NsA zqb*aBcIYE(ezF)vV!dunZ!+31p`N?yu5V>uV%^5?8-%~vAF7(43&QvHajG!`8P`X0v(2Z1)Q7!bW_*+DtZe zA0H32V(g8)toPPkCzP|wzR2a4>RJubr;_2K!O8ntZvS}12q{d~x0+v9Y_MS+d%?E~ z9oVkCOIWzjRPmNk${9Y*P{hk7g+|6RO){O=6d#A29{t2)acRxeKw9V&n$FE-DE+dw z_4}|PKDX135gIM2IpNYF4%q`57fu@lUnw+&Bx5`_+ zX7xJP*T#SAiY?s2{*TR1$&7Nd;*;6k*fatcQmp6jv8~^`_ehrHzb&ycqi5iz`}2el c3<(!~{%7+-D>LR*@Me1O&l!9}@G*4%4}v98Q~&?~ literal 0 HcmV?d00001 diff --git a/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.3.tm new file mode 100644 index 0000000000000000000000000000000000000000..676e404848fcec09010b01b2681194b06790d9bf GIT binary patch literal 11953 zcmch6c|4SD+rK4QQq~CJvXp&~n5F22V90)u zy*C!Z;*mZmB19mf2q>Hn%10U6g9@Txh$s?-0&Bo4FA4@r#^4~Z7fn)x@I)vWO+p}G zQDi(6h^OGlP>3Ha6g(mT2^@<~grtnHWE2sHBx8b6*f5BKgZGi}5ZMn&hESnoBGQ|T z@`0oR@je8+j}igt9f0&jDFvg5Bn%!0q48K49)<(~1SDi2YW@k51SyjPY0CU^pf3uC zA|hd-6cPsKivSQ|(Fg<<y6uka-j zU<09uL|{tEIT$pnkSSjD$I6fc4(SCf3JmOn0`?2U;83tM3V239lKqq+SpuF!!oX`t zNHhvq2dpAMz-?qA#+wXGM>3F;TyiLN$uC$5={bB5DhQI4gd!p!2^X3|s89@vOoHa$ z|KH=6gqDC=3Jtge*3}0?gy?X_}tBnJC) zzuOW4SR}BdFAj1c5wI9CZPkJ>CAT@V(*(>#<&xdBX!zA?0I|w^NW-Y-<*jH*5}rcz zrfc`ReJYEEfVf|RfC{0oB-9EaCbcYfV2hAIj)ADbLm?>08;Jw@!5NGs5QumJ5d#tj z8@5C|9IW7-H$BEkC~q72G<#sND4Z{-Fw#bDke(i-3KkPlWC{@ng;SS0 z8{PtcmTuerzuu+~xhy*TcOc;t;kbdzoV3w0b>Y|W2VPx1hpj;AcMl;#j?_&a=$g)qUGCHhyl7HbM~cGr@7>Yg{~Nm^E=>gEC>tG z7U*^gT~SAP*~*Hn{B$l3R6@gWOo z|1*U_D!I8WL;O=7y_&+slmx4=TprmQi$IVA;l4p4uOMpP@K|q;Kv)bUO$WMI@ba<` z9|eP;ZCRuZt%A&KLrhtY63O_9==Z^o?PSQ(Ha-(I|&m8&X?SD!bxC|~r zjU^&+zM$;u8#m-!4<8vb~Jya-tF z?ee%;{$z>Sq?hRN+cbb3g{EM!bF2h%@y7!i;^K|Rf%XqA6+-J9pg+Ts-5>-4))3wc z(Yg>G4f-~X+CYH00L^`1LNot}NT*yY>P8C|xI}w^Bj?()c%I)P z5SFywh$4G00|jdc@ zh0N`wH))!%m4*1=aWZ5$t{|C3Tto&Ca}*9D16Bx^%AbfxfIyP)fKtt4hd^*)QAiRQ z@`V|2AWVtCw+{-73?o5+h=*WsKKKw4M8G1+pz;Cc4cIFVk5i(x6C_YUZe?WlelU3l z8$pw#1OiqY2D%9lLbtw(3UC07jZR=ea{$jlh9H4I$su@R0FCZ0Ws9)s;m<;5(Ch*_ zf)8N6Pyh-5c3B=Ezb~eeDk}6)f>{b&QkWrA4joDme zEegZYnE!2VMk!q?Xxhfh6t5V+9-wvG8C8rX3X^LNbU&=y>>pxlDHsQ(cJ z42EVk5*d`jpI1;4xPI#E>n{r3x!MZp!fpYV;h*`S51~Pu19yE_oEHeiIh7DA?OnWS zP7sOW?Ttc#VS_8EO)$$^T*-gN+s|}_7SvmMrJc9y;_oG@8N-zwF8CCJFA?cOa+iVX!vN3;T-KW50>_~hrD1PvM# zEllR`+VFS?a4e7_v>^1k_!6+OCECU7g=bQ|%A2@pHTY(qhR=lE} z=7tLYOD``I`A3#0g+^krUVz@h2?ZB_kZ|)HYMCTBQKYQ4D?^TeUeH*JH{kW4d%~um zv4B974?Ko|fZa%t5|}@NUI*UM;{-4nz^P$oKw8-m%hL>w0C=#nP%QtLK=A(g%KHmH zUr_45EcY~mLh^+qe?}=hZe0+wKn;M|=-SQ4C-|NZW6&>w&*|9(69r^2sJyh{Abmdj z%am`v4$XhhUEl)&43M*uW@tdH=yP4V$i?GaBoPGTf_SAltJ8*#a8%Mw4`P!xGxmYJ z!T?XiQGoB~=DGx0eFd(f6}g4PgD*N*FmqD=eX7A|e?e*w{qkf0@t%N71hd|CL#nnPTY~OMk)tL$eU@AV5Je{W)3`wy|Jd z#m~UNz{VhS?1;0`)>Guo;HQ=?1A{VnI^Tchs+K*t^(m<;t0`-!EPDcaW4&%b>e-!F zo=+xtO*_>Q^HfP~rZf@Zrx6SA7-pe`M@efLE=AE_zPW!6} z70t!PRmD2AMu2@tMnZwbSEgt4eov7fC$leZ@s;FyFww+0ASkC$)vluL^7_r8`Ukit z_zaZLodMA{mJ4bMVhPRsgikD8OrAz(4$HpMF-$(LIoV@S-Y?O~bt*euR?PdspzI6w zMAw^-DGwO0$a?l}o;>O&bjSAn-M4vzhc15Sl%0Uqr<{9nR_MY9t+m&fGG9mBnaqga zVs5lvaf0v4tHh><25HE|NZrN z#7CtT9#-E<4~7nrL*mDbDD{IPRQFRy?uK%gNs8TgxOac{!PMqT?Rbn$K1Q*7?Tit5 zmz9B@9_qP0wE5BJMr(BlTWNBRqAqxLi=y`pKU-zYjHmlCbV}Ie8*-=PI4@5)^Q>3n zy2jT1k=YV0__ym@-A2zT^zGD`K+$;W)Yc4kD})NmXx^(w>;0v=cSvlwbvG|@r}l$& zNM(btkla%_r%{l(&gWMJmu6D z?1b;o@QtPnsn=b@5qDxDV*~qle7g~yS)#x@BdnKUr(BA`+f9f&NjS@j7IWG)>YHgn ztasj>FS@DxN=P+Z#^@hS&h=_cqE2^DrihLXvUOU?d#w_a{&LG0ua0ST<=~ucifsEn zI)%%zBe)Uxm_s5aD8@A(s-b84@9g4=Lb2|aeS61JorCdR+KGKTbQ^KZ$^?;vYX3^E zai@M}!IKF-)O}mh8pv-Xlw%2X73XhyzV3gBQ?zv3dYCG)k7=C|!{9el?rGh|ci;9s zDd6}Z0NpBVQm#86F!s@VZ3!34j!nL%n@;8!-$*#l=Bp6(Fd=Z*_L8|8BF2$LP#v$z zX?~b$HgHY3@p}Zz6MMFk#%;tS07A>VKw^cX(Fz2}pfA1|_tNAOP z@b|l%Un-PPg49y#XFm^)a=0opzO(DdKA&3}bRkydfL7gAGYJ9D(>*cl8SlPmziqNp z7XB2Zc*nmANOO;zE2$pgo;d=JUIwkm2qavtf#9)0hYk#ZH!na85lV|Mi^W7TC> zZf|VVOv-QpR%Dp##>Ejw);=u6z?LH4;M%5?Q&85~;e8v(DnyoP`*E1V=IlaBfGmBcpZ6an!RzY0;Gq>8tkGs@8XzWhc74F+rxj#x(dp z`72W+!8Rf2k;Fkw?+j*+3m-##2to(UG+s>36z}dfRNj<*AN~BDu64X&=SaF}{tk}4 z8j8a^(q&rB@k(Jqg#?ujRn$5GcC|}mCTZOAci1mVHr|R)5S$i`TVGrIRQVel`E_uT zqi)k)hqP7SJ|B`%G~*k#NJF_^D@WWmvWkDm;V*VsDt$LcS8Y)a`wlM0JZZ9GVoniq zUl#JbNo1bMy3U|@qHK%Pey*Cs>J*aJUslB}vaYA3@11C$m^9|^@L>HOBRm?-rC{Ek zf%dzYTe(g>CjF55@S&!jX%p-FWfrZ&#;+_B9K=duTEBj)4LzE}aHw@-X#1J{d!DgA zzHZ!6d=ga=?TfeCT$T&5dit+B$+#Z+z`Mr8m7|JUyrn_T=GLadx++Z}|A1_zhu612 zEeB7B^Ra9tROP9b_1K(@Rf)nJH@V=EbH!20tX!ib!C}>{?CFa*_QXK*4cF3e%F_F7 zzxHcaoXDzkf)sTMSw@KtK>}SLQR}A}wmgqIQ^{v;CM{x>cH(lOjGU_g$~Ec)_n1$~ ztsKtU9Rga353iYWth?=!)0>Fp!)mth+YQK{u3|j+cbvg@=C4<7B-t~)-x>F12WE$4 z8H5+gd@6izLw4C4{gIJ8VK0iKlkAYN<5zJC*SUV)Rh@45E~j^~ygAnOVwxkng*6|! z#W#kt3tc{zW)(Ff{k7=vk7Q>h9RrN2V~xO;Sn|06#n6tOSFMgUV$yvNFeZ%irwD2D zPCVGCdzAS>!>+%w&;BcrD666)doUx>pQkX#$28rixHDk=K7@U=+$SdigG)zK98Yy? z4qj?+D@gywr1R=)h)Q>g;3xUW-)8b(@`H-;xm_5p~OD zJ+BG^I#{QaZZn2kU7Or1S~j{(f3wzx>f7s9{SC40xcrx!j@zd#N>VvUrMhkMaE;lk)WlG{bZ`aYRS zYxx}4xc`srN%=M5a!TW`O@{pQjW@I_wADY((+Nrz+%RA)D^vZ6(Vwj=(5^V~FJD#v zP$k0?IyL*Xko^4EwIPAdg+w-gthgbnfR(A}Lhafjy!P#=FWyftk{=0g=SZqV9dzfr zdfs07u;lK0F;4r@k_!7;aWuQXs_k8cz8x=Xi=Sg%=f1&SM5O5+>2o^; zi&P(1xtM-5S$pphi^mhSs10qC0$!H+6&L+HyAFR=D|0 z5l=grPAPZ1$&HU$7|qZ`SMIB=TT!i|e_Oip3^9hK-{r5NK5rutgb#;lL-}v9YLKK9aN59&2w8IN>28qMUBeo51FbLK4w3+?iIF@yTi1VS0JZ;E7pB`Belu< zu#k&VaXYu6WmWj(=-ZvA%D;2;P)9`b6Ad@zEBz~tZ#+@9xrfO0}?N=A#*S686VFj=U5Bgvrkh%D+&^fc$@mRivqq`qCFRdFgxH++4Wg<+$uaqlGWfr_DSC2l1W z<7#$frSvH0Xs-n)`}&Va;T-LUIl8OJQlS&lIod%CBOCd*I>nyoohGEzBk#ZN+Eaf~ z{g&3wS=K9h&oDWfioHe~6M}N%lCBhei+JhF(XVm!>jkycTs9wz!+}_4j`63|XJ?0> zt+~#e+u5i6Z0*ITT^|l9t8nESwq*&73<}=kXQ~>vxmR)iEqU7`HRf}iHcZDoxL8dR zq!TvIPRX~}jm@!t`NA}PItjH($3fMB>gCpE)NV0B+1KD29vN@VVzVxq@ky5EA@{WurFPO&aF^-7+KANxY0vdu4mLW3G?wOE%>2~b z<#pG+aR}3>t93@c{O!K$-uA1_6B`F0BEpc>wm2vc4xUodlfd18pzQj1!igUNH%#UthoHUO1 z5M^ejufDg>b&;@6Z7m(&{Pn(}W?P^!DQGJcz^z%*Y(&&L6pfef82ffJrC#E=3!9kX zF-2BVC-m1HTch@L3VQ9qe8iDlGco2!lD-=i`vyuAk**h)m`*J-k#0r~*lP;Mi@ezu|`5$KbAL3<3 zQ(K-UjnqmcotCZ0$TytW;NQup%pySLK5bGO=D}=#AQ$I*FVDw{kh+txy{h0FV~Fu9 z!CH$S=kNV6#B@78DXvNg-RKo7Jziy4?GXM%4Z-s~bFC*2>S9Y+Z0AREO@J2oK0 z2X`Fx*mG(lPalD(XmewHz_H1Tiw(;gZLW4UqpMFg^Y!$(Hj`{Ljk@-I zd9-aq;pQX(5ryNQ>x9Q@byznsIj#;!u};f9uKM87)ICxpBS~s=t)81Hk>Of1^%TaCwtEwMT=a^yonridgU9Be% z_?_m^tM0cEY&_&-a%$^&$Nm1#x|1_Np}<%Kmj=|~leZ{^+sB8nerP#%&?uro&ojQK zMdOSUbnjoIRV9jbL#;fwN@FLkjuxk~G4Fr)UL)yXLCzaWwxT8O2{oT9v z>1Tdw>Z(hxWcm9pm~NQ|=>Q zY&Ru1zh&h)vDfkPx^kr5wsZbYPZFz2@u{{l_B|qpv;u5AF&D9)_)(+z3?$QI&b<;p?WbF<$^q4$Eb)??}p*;96a`qFO6Q< z`nK?R$mBc7&|fG=$k2(gec0GtxKI6>Q>lcP@_yFQ@(K^+Uy`Hl5saD>`1UKpz>qH`Dn}c5Ly%59hRZ4t=5!`*<$r9xy@uNO&z3HMWgY zmr<;Y??k$MkWKT@<0f=bjC~DJjL`1k&@NONGq7gXFXiM^i}U4>H%_0S4m@vUqn|iK}Mtb_FcY|6wmR{oFnJ!iny8$c{2)+t$8tNXh=*S;JfY1 zD8_o?dGixne@jwQM9E3smhM-RJN%q$F5>K~w|kh1M+wUFj*i;y-Z@&EY{nH5k=<#O z+e^{Yz+2Y%A00Y)f1h~l@o*nwhi1+3H!66(c9~NIJ4wDB2ixpA-FQE{UfnG!JsP;~ zL;hVOiLM4g+j#NAyWi&-75rE=u=r>13nh*T`nE0=4RZUNp9(##Uq5C;_S{Z z&yQM*s~CKLRU(>l=H}xrL#Hhb3VUKNCmP#FZ*ug_Et63Q4Ge$3-Pyy%=ujLJ-yxB3 z-qSS|+2mu-g|LcA)6Ls*7ucBwfUd# zQOSK%Vqu|NVy}|}uJW=^?Q=B1#T1;s77<~tKUr`>dh|%1ftF?Z2BBmLOlj5WW6#vC z=lZub{u|Tr*L&_9&nHLj-9;AkRs=LOg-pGEB#9F9`#OL?tHdYsS#AzTr0pR*4dUwC zC}(+(sob;wjoQ7i+sY?Dg);CrhFXbauOb|%`}Vp1>0onuz3|)V9cIVIngjRXCS;YX zIh&{%9R3MPnJgh!N#Bhw%pfkSed&+tuJ2K{<*d6klWr4NMX3Vb74m@udIuMe|6Hm+*u zpuDMOUw^vdL;peH!v3>-B^KAelyP~u4HsnT+P;q*4u2qD*5Jr%=*DOp`uE;@f;|q~ z!_U>4L83{e7ggmp?){`!5Zm@vPG#m+yqeHi@@)3o!$Yh$pn^B%vClg_`X1L7hY+XZ z1>f8W!ZJnJJVbwTAb)sf|AW=Wf{}@z;rBB~Fm_z@`JYW7Z7f(;!pm1I>K zD1=I7R8+tFIR_E-9k1`}clzTv&vW0`{l515zG8zGd?XK`36KXGgM$3gWG~1DiGeV9 zggc4|5r`-P3g?b;SAzDSd?{!miUgs+8t}@Eg2s^1I0)?ZASpn2BIM^m($$4Uk?{}~ zPr;EPe=k@lctija*cO}!Ng83uC?XC)M*E>Kfe-};?<3(MvKN93p#sQ61d@z$ha|Ch zcLLsBk$^z@AUsiuekdXdjmJSAcnk~=O@aUd5(0~wdx9WAN@OfmncoidMBz|G1T2(7 zLgPGj0Yq4|t}X`crmKrZ_@G<>1{c~>ND=ShK|+zqfdmwUAR@g0Oh^yBhpl7)>5;M2 zKNhKk_JD#MkO(r;3ksqd6Ne{a5g7CV6y$)$dEg-ul87ddokHM~;RWEYphXg31EGjS zU`mNu7*wl}DQ>jKO3+>$!VOpy7}y;J?1x3;P_Q%#ct${wy_6ss0-i)d!)r(g4-~Kt zSVe$<+sH&Tk_=2o+AJ%v=+KZwzhEV#X7NENUr0g%3J!+E9jFSS0?;Hf37UKVzsD~D zEdsL`8gK`!t2>$q(cpl;aIov=@hsXryW9nVb9Vt@GrNa~$CIg>Xd=i6H0IZSr$quV z2w+K19OOVEV9;dhs(E3GPP1mG3Yd+`MZ2ld@VnIjV&%DzhEdPSTh@{!JcWp)Y4@jn z$_s^nxL<@I1VUj*sAWP-a!KsK79oKg15tyA{811Rfdl%%8H^whhgav2|G&=<> zt0TN@c}13gIvWSe+HC0#SbYo@glt>KTe?IMhr7%b( zC#NNdf61d&Q@EItU=^0iBO@`ox@0WeH%R1VM9moG#pU)sYy9|{O@*>T6~fdHM4%@$Zv1|Rl>k!Z~>FUB7!h0cV7s7jh zzD=bz5MVAqb9b1~%snE~DA%&OQG*38(JtV~*`A_IGdLAZkX*=OAWm@S0qarjiog{x zsan`PmYng&?g5+pcLTtZW_4U5Xl_0A@P%OiGdOHZ1XDdnEnP@F77N-u38LmE%+df6 zrJm;m0fHnU@u%>WL=ZhGaNPj(73PyjFF0;Nyx}1?&;WV5Gb)m&VW_Qw> zG*#I0Lfr8l>r4uG-I2rOt0;5o<;1n?)>A5Zk5(%r>u5jH*ina>QWT|h^02h11p zK>@%HO9SN3#Z*FBnHEYg%c3Qk1cXDw2@QVHg#Rh9U>tyEkqBrq3No@Zn~kgm0Xm=L zv!;gp;Q|1z2}CjlT#MjK5e^SrM{uXwL~)jx(H!c7!~274$)ebWLljRTLu6tg)o|qH ztpg*YX3p$QWm)gQi{Ovs5_`>)WoX_yf6HS~?BL5B3JdE)0v#DXn>_1!1msV|10Q=* zP$Uv0gCLU89^l#sfue|jyC|HP;Kl+xzaVx&%#bK3X!G)6MS~516DWWSNc;u^SkcJLXbo^DdcJZr)uX{}KcYhH5nu z8I;0bS5OkTei|4UEC}7%+6w8xZUL9!U-@7Fd4M(t?)r{6HxP=mD(Nn_cj2a4K_m(i zi9&&4gCnR-Fw0t4$$!P$uXKdw)mwa}owMu0??tK^!<8K__!NRC5#dhdi(u$M1bK}H z)en?^5O%bp?|}{g0Z2sxC-UD9T1qeGApH3a&8G_^e5o6ky)^!Q`TLh1USt9q2Y}|h zOLYfa?f=WeXB`hbM>7>w9%y|I3w}EN-FSSxh3>4H~b27kw;OM1o1zv<(@v?TB9V+~n zUS1;duPjm01A)P~0eTB36kPm4!p(80C6eGok+j&N1la<5L1isS!0SQxgiS$Z0a%nf zJcfXP-AIrkm_LGE2j0=*1TY!EsbOY7THX;$(+rLPc(5{GEdQE7@cy~V`x`%>SL)v^ z_f&#H@`NOQMJYUPofk7t4S?Bb+Reo$_?`=6&@X|{Y1su61%w}{ywu?!Z9e=)?0vz1%QgI0GJA^t01SkC`L z{f3WOzJ~w#&GPGio6rJB(XI*qmRXmWV(}S^f5HDlGav9EKtVD6HChz1+`+hlkB*Lx zg|1^m)c(e>8=qvr&y7}ebV}gqT>qJ^S~lR;r>LT&s-&U3B6VR}Z#HYq@A z$ROlJ3GTGoU^~KutN&$VV#rv|`B%p?SEM;@ICrl(>sZ@ADAlPCI`TN3Y2gqLPEO7; z<^gto)&Xg8c_vTkCmRm93ja*bysY6V!TDgUfumPIR=%uNS;yhc+lZxro{tbIJC;dmY0*ktAIL5DBKJ8P1zsNF!NiuHW+c|gp#AR*T_!`&79 zW8IHULx%)s@+uB_lsH#^WB>R%QmmWVnU3>|uKBAelVth~gQnd5BkFs868#LO*_*hT zJxg8a+Jqy-P8w0F`h-KAQ;y#Y;3|?3t$wucK<3ee#!{U~wB>oULiegEBl32O&HDPN zmp0Ib$6xDrt3jC3t>-9e0%tW8kkwvRO6Vz9=aU|Bfmf?#Plt0{9ox^nMwRmhOZOz> zE)Rj*j_>vAUB^A{CWK){B16Wt(^xHZm6?WfUO!&rE!k}%E?9dnCwiOCgVhK|EuJe! z=*oAqPj14Vb5U8{O0UFY+Ox%EYXAq`z)Xc&(+vx?Vp6l%hsSz+JLBV0G%#bH1B2BK zX_9X`2ZQUv4uxW0n9Nj%reBojnG(`ZvsSu<##@hx*^BR&5h>uXt~W5#f|%<*N`0#}#;c)Q9N9R&H@JBId^e8EvL-kY zcp3eJ$0)`XpUR=<1|O`$^8+x>yL$GGB<%OYcj`pi8bW6;z~ydl_j}%T;IHSgj3k%qT+j5nbPmDc6Kv{f8O5t_y6R_@Uao z2BpeepOH!As*9XVChI*-*C%HgS4YLOc*-As6onnMx?--X8)nNSpoUlBFh3Sz)_X&# z{zouV7k}+bch${PfSjUA<;ZdWhNR z{=};SqP9gZ+=!a8AIXnhLiCl7Ztd}L~Ya^osCPc#5+`RcrX@-UT#xKTJuVLTb#1%7N zBcv6~cn5bRq8x7&>)ti8hjNv&g_jrrPKn16%`4To~do42NUcwNpeU9A?D z8lg5A(ePwq>+btSJ6Z;fU+;?AD|#`kWqRgjz=51>yyj+7!WM~1SM#K09r;m?hm*KQ+%MKzrr#nxVCK*)Bw;wG~do|R#^SbL;!%80c!&pA$rydmby+hXJXs-qnHP0gii zg5pEkhYxKpN>0nvIDN^1{fv?BBLcr3TGCP4wEt?0`fWNBzo-U|b*urNt2658JzwSA zdwAcEeOqG6I=(Fy+scnwTdJMkdBtY9oJ~RGVh!Jn!U?e_bq$wxj0*YM4-K~MJQ%v} z)Aw5fqYWpTGhg0Dy5>3c8-AvHcJpDQ0b!!&c1mmU!EY;sEULK-dyCkP3y5%Sd6B#` zpQ6p^wEbP|z6lXAUg7Ac2<9*suA>r9?-i#h1)t&1GdQ4q9^1b;Z2cM$mdkd@8@6h? zdu6?^*-}0lpKz%5^bZGC!MZr7i6ou$@KagJ$~IOpj}2wHvsZEAW~6w8)f!Vh-1v4R zg;yo=PZA|anr-47LrH@#h99NrG_XgHi6k7w<@dq5-5;I|PT6M49%n>dm3Q`5@WrNYmXhVM%3-%TJ^VybD(GCq zo3~*lBZ7v}gMsX&8`^B`G*o>4nGs}rFlMFL_UiJb+mtB3uA;#`2OY?l3wVdQOSC0i zf*xKK(%YuQ;y7?tZ6NmLhGLe_hbwowM?I_lFt|}?)jySMYp&fAbxI;o%(T<6<5$cn zzA1)Bjv?4<`1qPHJQLXY)k1LJ^urI**j0InZlS`g?5!_^wUovCtNT^|i7raE@nXr! zeNq)j@z2>|dnkO=V0`tSZCN~R$$s(L$lGle#so1p!wZh*BV#)5GH4Jk*$@VAnsa{R z6^>9BWye7c9A2?E#0It|UKy`Bu#(rv^}IEE>RKf)?+UqsRo$smwk0!}vZ&Fx;t2=D zbSB@q`rwlr;-2V_S5|wDG#0wC%DH1F4v9JBr;N9!TP8(bwk`X4=KFp06VZD{{)6YByO9r|XxfDtCD_IexQo|g> zPj_&zu9-v#W$8T1(py263>cHj(($DmTF0kte{zhKSd}hb7mVp%-|pD6KLjRC>ynGF3EjQ-t<_N@f?RGL%a(o^VTS-sCD1R<(jO9 zAC~U+OgNDce#fGz&`79b^vwgqOb;|suB^C3>_JLbSJ&syBO@QGLnt9t;$OPHF-)9} zL9N)hS7mRAo6|$1)*WLMyBf!!Ly^0gELVrpcV%csIIp@GE;>`DYWVC(2E&aZ^L?e| zs&tY*KF)#qTEe#KrqPz2s>!Yb+fCo;=&s~Xe5v2xSHIW4{!-TE^e<04-R?Qp51{My zw9d#Czqh-Ev{`8$T~n`TuH5j>x>|jsZJG6>3kdnCo7kzB$F5v*QO@3jcvj@?VN~xK z|2-q|Wha2cx?0f{rPB+}h zH1tz=dO;XDXK% zOl`mB=XLc|?n?agp{gyJ+jiOXWV`MV&1)2jxndf_OUM`Fdz9`S!Nceg()285=%#qg zX_=C=^M+%B-tF{CO#C5Sr?*}TbYZkPn2qyn&T+ROBy6K^ExRy7?{EBC;O35>xy?Tf z(cQLP1!YkI>)eh=jg}df?+xlw)#ZMfzRHywb-5|N7dvvL|I7 zcMpN6U|BudYun()$%0`X(DvHY*0+-9?1r-&6I_xy3cCw>tP&69=BZnjGLQ9Ecm(!J zBz8C290=gj?XNmQNWWvW_kCHseUTJ?lcTle@XF*y-X}edjU-D=qfWbTk2eYCZHVC) zmXH5hDKv6(BlCI&+m$|XyA!kHRUSOPdUCUHdD3CCw+-}-O44`C_T0PBKg2F(>K62h zz17XxvbCp-jfc6cWqqri&bqvmgH4_N!(6(|Dqe_|)I?bkE{=!nA zKEi%$igvE;0q^JCv1y=Cpm+FP@~OnfYA6QTMEWy-YC3t;D7Z%7HS$T5`Wbtu`JK^< ziwczkE!?%2j*ML&E=XWuJn-nFdd$)K^%uVsx;~TlOJCRMo_>IJfTe9j@0F{6M9cnq zw95O3L)Z1o4odA7F8I8;m?+UX)V?dRXS=wrhD5SQHR;&f8C;qI6qyyjx;5S05$A z;Gom}pGTrHci%p!S2!6Onln+Cr&hp8DU{=F8y2>IDmeIqjoYT<%5b6f`@DGn&mSN| z@3mQL4ejY$2aTPDdem;%UlMmyI>0lV1PKXFMWSq=8=MyZfpNd z|K}#7jNK@iw{HRucm8Nxb2_j^wKS}Whiho}nZD1QE^i+*$Ht9@-M?b)a$!5`-joN3 z5j{oqaXw)^g(zwD#=G};1AV= zmG>@EOz_2Io~G{CpG~~>S6s%~ly7k{6+0{-$1^-^wR79>%~&%||KQAaqdQO6_+(AA zRBn1Mr+mg(3t7a`^x+imUezu_eq87-!%WAzUB~w%@)+!~(l&pc)2kMAGQT4AUV;R3 zx*em>R*_Ihr!H<~(GT9O>rBbMSuTfvng@umGksy!<5uo|t2T+Zk(Aq+kg%nrd(Adz zuw2LbAs0P^$(Sd}GOFLixb9R~PuI7bA5B&{riX~Um_#G`Vz8Q5Yc3AIJ$pm{ZM;6bM7YP9kd%cq-+pU zIrAmql9s;rO50nEs7G`qrmNc2R$DP8JBmbJ%P4$R{;rN49fDfy6n3^BGrzUjz>`+fbc+njvauM$5n*GTbBGoB$n z4tm|IACS1IxYt~&HNok7D{JzZflsV*U%ONGCFMuP{^;I`a&y;-IA8R@ZHr&SXv9VR zpbGXT(|Y5>VNQcel7mU!w~Oh;Ubd%jMkfYlVULfTu3D#SrI9*{-eZ0T+n`S%UDQxy zzaCbQ*Pt-C>Xuy}FN39UzZEuEu;%N>PlHpq6VjfO-q)WCtT!qitT4NA=kfJ+&2>}0 za{02?$oxIM17Dd-UyQWY4+Z^v`}np2!kB;P)T=`2yEiRNO-gtvH7S#m%6HHQCPYTO zRWCzP3S1v7jSX1Q?Pn`wVzEwfA^169?q|6(yyaG(`_pCqCY#3 z^6FK=mR{BEPKPEpzc1r_UnYOIv~j?MZP+Tw!Z(8bC(E{Q^l;YXyY2StH7~E!ENbkJ zf54JbD(+P9PRQwsepol}s_Lrdh^`2gjZ(Ec`}(1*N~Ag9M(^@0%O+Jzd;s5BsC~D|VW@x=hNAM}mM}-cYj|4g6{KaHCGd2kY2fLlS zqhb)hd9rE6ccxXx-};73u!SRC(g~xtc#H2%2Itd%>@C_nw4QDJ!P$~88<^4&*LPj` znOk<_cE2WT$8_Lp!q?)X5oY(BdGc3GzFlJ#XjP6s6*>LljA4aYb90#UsmZG;8|adY zci=7ZYl4$(rQ3BToHHz)o^~i7{4%VoJn{N?)Xz;WlznKX>Lj{hwqv!^<@>9fi+P^% zcI;w!>*W|8Zq|Fb_JgcQu;1>$+X4o0jos%*ev-FqY#tMl-GvmI$^G%ZxN}!k>ZQ%M zO+UmUd0!og(z=V!Nhrztw%KwAJp&)zpQnys@VMafpUogGcQCDlH`9ZEj^LXNA4B(l DsWfhc literal 0 HcmV?d00001 diff --git a/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/packageTest-0.1.5.tm new file mode 100644 index 0000000000000000000000000000000000000000..3aba1ee9a55795a713f2423a33d4e2c2277ff70a GIT binary patch literal 11963 zcmch6c|4Tg+rK4Clr0q!cPL{Q5o4Y7DJ8oi`7$hK39CutdDFEo(y^72{_0fPxFTC zFa(G|LSu0hh)lteaYQT*s|wlR_R#SZ92LTWHQ<#89Z#U)i4fT9NmYhO6lkv}6^VpJ z(MXUViB6!|%lr0wFpP-bW=tG;cHw!UfPMXbcU9 zg=GCmSTYH#LPleJ(Ox)}y*LULPa;B|BmxW%PlW&iD%uY>{RB;gRB3)pWqv!*3rECJ z(6CTC6;Jd+0*J6^B$9ylKqCFnzBo64!HxA4QXzSIQgJj|AQ=atDHv}66VeCoVJjIz z`ZPc0A9GZ~dqTlZ7&Hyz4FxleNhDGH&;)!C4sya1JxLH1L&1}2E)4i&cmen;c#Z_v zKsX8om{Mj62Gc4ux(DmADzuY`_5c4rR>w1uG#pg%85*fn;Q$efyv_PE3Vx0eC8n3QfQN zzsD~F%>gqP8gK`!D;7_ISa85!MA-E+c;;-LTJDA>V%8d%bc2su&71U!woYDSof%aqxf0;ZyJ&TeKj{BAXXSZz9_Vbs&|7PKUlM5ka_ z+Wl#t+H4^p?&lz2KsW*ww?K%=&Wjz`B2CF3K0rs%yl-r z1^&$4w&{Pp%@A^$b@-n^!Y9IU1D82D)I4?J*YF2kf`a5W{dK`6NDhcuaLK}|P9Ge+ z@M}*J1&0Q;B>*6Ug5kvoxd4Sf8gAC|O$)>TOOYx2GON>6a>GIw49Dpm@HYX31!xN_ zI|VGLBfM;3MHYTK6$cC2Z2k^deF6qe#ksL6u^ScV<%c7J;^YKZI-(aSkpzM-`@VGgn`T8EYt)F zn&<`E-fZ-&((N)U4}UuY0uki`>B-VT(SnN(jsl1Q>|-nhi=XE+SZVm<0rJ9k!MF3{ zX8w~oW|Nzv#~;%Gc9bWbK$v1BkdqGy&=4mKi3r+1G*<|-Z-D*`OLl>fNLWL7FU0IZ zBu~({nbZaX%mrwUg$d2{BMOUhEvOqaSl|-v29BKSDQYZ(GtmSqGUfttfjbXakHe|} zSHPrdcJr8b#vi)}Z1Ud?085(Eah{;*^~}R(gZ-bu;hQIz={aWU!jSy@K%1vR%-n=o z8X%&~^IRZ6kYr^36uz=(iWeQO8-TvTd=ldg$1R9A66688AYe-%$KlsZUOdfjkw|l9 zZ^Y3s^FYDc%Hq&)=uWW$Dw0K!r*|=NkwL)F;OB4@EGz_&RM3w#)HO6!)OC^2Tp?3C zSxuTLY+)f-5>cK8#}y<$i;KtuVvZw1G{6esQuzxJ6%a@&2~etO><|bp0uD{3L0&Ke z_Jb)A_{QQ0=s+q2h`2wVh$Z<`Au<6?1C1s040&@3t$Ps2edt8G(}H7h`8 zl6=b4kUv}iz%_wFql0S^d?_N5fa}OurcG3)m>J8VzC@BgxR%U`T{uKZbQ(mX1Tqar zTi7}dUXpomf^=6~!XGiZU&AaJ7vY#aYqG_d2=Oy4o*Lz{8QjB+#XV*E!CFc_xQ zs5DRte_cVT;QDE3XgDi$r)n#t54#0ihJWRQA>;|#9JuQ{6FopEPN{@kXz%PzQ-Y{; z3>M< z2h|Uhe-L)8qVI_h00GEE0w?m{51LOerXl?K4a=vqBYeIa7rZq7e);>49-d}K%rKe0 zYs2Fqz_CDzFo!VAhQ*>UklZX%_h+mNyOObR6_5qBh-K zxShhS5GES{9hk7qjGe%h9E=~}D>;jk?8OoBU>PW=zvg6s{lL-7+6ue~x8eouG&NNC zUwV0-$iK2gSx+>9-~s3@oKSG_2MIULq2@_~6GhfylPY8n=mnFtU;wWN-4iwilLh$U zu<#fH0(PT9Dq#KydL4MjiW9(O0H=nT0d-+V%uh2o0^q^QOtJiH0>S&IEAMaod`7AN zvfMKX3e^je`4y$`xOGO%3^f2|V`(=XpWu5sj6uHyK4)bYOcc<2LFHu*2U+vk-==)i zb!hr~>H_ZvV1S&J+2#p|6>F}`5;=REi>82JoDr`wWp(Dz5spfh=|OBVXU15_BM|UJ zA|3dCYOYIW)>q&vW|5moJoutR05d1mKc^au_BW(>>m$=<^2~C|9{h0;KP1_-Z@pdr5KfhUc{cjUm;3(EL;lDELJX6d)W9~2be`sa`9t0>TroTpu5>{rMi$vMj z*m&8L5K)dkfk{&8;3wIdjZGCio$fzVRm%?C`c%|a*Q;u&&3giRW0k&d;+ZX%o{cLZ zdD}xA63n_xHh&>Yk5&&&agnb(GjEBqTA2KK^6E;3bW7=?2r&I`+o{ zJz8+{LZ`{8mSas57yO;VCF6 zSk5!Zzhd#A{2C=LFZn0yg4|dAJds|y!AnN4ajbSp-%16g@@6$1rx&jdRW%aZNhvt- zdwr{$xC+-RNku&nC4b>+<8VivK8zU9HI7Tr`tZc4xMxkPU~>8?gcPQ+AJMxw#`)G` zdL#QKgnQ?@57FM@_pIODf0NyRsPxAY#2BX=h~=TPB6u z_x+Ikp*IvNHko@l)U(9(#y7S82ZBbWg4fxk#^_1aZ=;nt^%+U#6>VNQKVFRP`?NAi zR-n=2CR@(NB}P!haL~Pt->$1JJN6E8{6~LZcF{+}#qx=mJpzw1OdmOvu6h$O6qgbb z6jXO3-+0Hl53%W3;|`A_n@6y!+IWYWeg9@Tx4gM^9cqyJ;LWgA=NI?xtB_IjkfI2e zzUDbyuNrctD=_BPP{Sd4uBS+Wi6N5CvJ{#tU+dNfxk{~DN~1TaA2_yEJeHiY`ZhN~ z4$H&tlfGiqzjO0VcgYM+XSt)52cr&;iLupxCE=2&saWTiCyaV>0}&_Xq}A{py-oE^ zjCkFxbwy2Iqqu%@JiQ+Mg~6$}(_Ze4R*+7v^R7od=X#AUY`SQLv=KiS!$=?)3q(CL zw~lbRujy`Rx&N@Qn4-rb!&M=+T<%ndkXi6U5O5e>E?Fs)#k-?{U$vMxbN2q~1yI+q%!+|l+zLpi6 zEgw)ZK42N|5@6om_PSQWPMR-jd*jjV%BaYF%hw7w?qbVc{OnOzO1#s@eM70_owWu{ODyYBtrC}+-?<>dk$f=1*;95yfu2u$Zjf}luajS- zZj7&l-b6x21p=?8U+h?QZ@|Z<|9H)V%2B%lw#n|Y8v{CC?*w=3N*|Jk6sX-n#Up!D zxrW3=G6NGMl^gorclqB4$i4RVaHJ6NZJ2CQZUK89Zck9t2ewjKu}6AF@rW~l0h2A^ z5`NwZBibmoAFqFKw}~B~W!&Ki9O9eMZcyOF6lg5Y$#M@WN;DL|+;Zghx`&U#9v92% zd5LC=K0jx|>szD4BkJ(_?fqVj$pp{pmv3!Pm4-WSH$2mD<5^&uKzQE2ntGpP|T zcXk~4vE_(l-gAK$R!QX_rHI0~;X#5-s?BlhO4V&AlrsBXMj~=<3QTfowQ@@DO3Kh} zXm&Tjti~?VT#9R48ecwgB<-|Q^2w&i`)5Q8^zFD#ef~;+w*tk!N#P953|iUU}h2M<*U)!X6TgVk2g+Q zy#Dh#K4P!uRB^~L#q<-*qw6^GfqZ?J1&d#Ab=CvPZ!=p@f4KgO#3Mg6gSg*Xvig(*TDDYL9Ie5h@(N*(8WoKf*AW?O zl+=&rY^>gTEd9*u6)^}kUBrQu7$4!>46NxXY<{cnatEYcxWbp+D~v8g$J-}&X!T!c zZaRBvl0$c3!e6Z;er2-J&CuFvi)%IEgY1{+>4}Wq;VYqPnJ(WyF5Zx`Z%x>3r{yAQ zNa(P)Op)qZ*}PJM24E$$YpI=nWz4^ z+{yIQ=A{oGak;gx4-;$pu)@PUr=--|z3uSV^`a?#*^W84(DtDtqOXgcn$AvM8gjRl zZ;x4+sncZG(gb8{mD`YNJ9y}DtXlhH`eNV*he&_H{!%J3buk!UW6$Q~Ho}s6{H{dTI z4Ge_e4%gFDicg0;84&if7rgF#Zhzt%e(jRvF#X`=MP|k|)+U`FL_$giJ5+>JsO;Q} z(PeVOONKkmmMmWW2`!PK^KXX!BART#m|TX=9=0J#(T%$!j(3ieQ6Ek_SW{3R0Vm;wC(*NRW-p(_VzTbL#|8DAC#IbUvK<0B8}t9 z(Dq$r73l%{^^Z1cG9 zS~G~R(bqn$Sp3G}8pe)$drWnW{&uz6*S0q_b?wV-|2>OV`h3;z^RvSj3f$B(ZO~7P zd^}M#UJ2jRlCI_#x1!jr*i5^mJNB*4H5-&uxMbonTBe&yyGKkAbL#KSPut2Hx*m-j zua7gQ_YGG1`M%%1(@}-kGI8GCejp|KZLrCj@;<}LeO)mJolCNA6F48;!0*ppW347X6Y8Fgkgt%|`3ES9_Mvc+V#~>1l&`%xV`QnBkniu4I7shaQlm6^k}Z1oPl zVq+(3ucRCARsPpYZO_9--OmEX#Tx2biE&(#VFfBH4Xs3uA5@S>Zw#yNFI_b$@la}6 zWMOq|j1+E762dClp)N1qYMrS(@9?6DKyulRys{qR{gH-%7ovq#u9s~);|L8WFMA`h z>D}pSC5E53UfSz@@z^UEiBw{a^#x5i0NsIoQ>T^hh)00v6 zGo3j*CZ?Lsn%UJtXe7UaY&?9Jt8C)xc?23B4* z`+4r+Ph)(CeS3a+RDh&MgxqMkamCKy_Vq~NXQ@lwg>j{Iff22rXqTJLCS(LLI^;iM zv~HcrPVMh7y<-!n-n3=YJ>zS(6)8%t0i)LxDBYvN8I|JuO+MGh-I6(2mSbOy4(|Ua z+RY|eQn-suQMS4<+Gk(uA;?SM8Qkct*V4}|a%SBb-9)$Jj|)5UyR4H!&*f@bmGO-A zUG@y@lS%4$U>6i1gnV8VK~BAe+WDqDVRw-nNzd8VYMA@PgJn;;oF7oFv`}ph-yZ3S z<*tieu}Uf7>vf5dtGYaEIqbQ8<1Ldi6Vw|YT|8>Es^WOqwpX?64^-uEZL_(5_W2OM zw5dmMFMqR#t5tJXIiCnmdHvdE2OY`WNHR9 zh915~Ejq7!eXw5mc0t5g<#2u?FK5ud?=)i%)T}-KrO^GU(%w|b2iVl0#e=*pBl^AW z{)g%vYw+rCnuaP3%0uKVSLJ^&DyGP^4Yislb!}aPl>Kq^MQo8BPAL3S+Re_TPrr&X z5*J+xf=O`^g_jDEyJsJcZ$9I!6$6@_`-1E#y7bM z{vX~##y;X1;>Nq#n_rr^N_1&l*H4yV`+GCB?1CyRF6zAeu55Se`i=sn6w9XvpYVRmLD5VvAp+8@EW<>k>6hYt zFoly1``4bZxg8#9aMlnVu`AW_UV23Sf%jQDTL!<-DP6)BGeb7xen!2J4I9y0qR%c> zwCwmP#XVLJ1|QdY=Iyt;OpzityX|ZiFWcY8|J^(O#K$_vi~e!7c3sMLJI^=lLJW0U zJdmZ*AzT>Cf$Q=Z0*C89;ksBRX?D|J@-s>kfqUMgY!UMEb* zR%&33hrIvXs~xp3D$lw3A2T_sN#ht;zrXF$!{q^yCozWHTnbQg`i6V8>u$8<3QDGb z$b_+k!0~OMpR_$GD`{+7%+;GR z>4@ZQk(;X;Hm8Z|4&9Y-kR7h(TCWna!FxO%vOzqBv#F*cliG37}1)48Ho^? z#kFg>%d`5&?8h>RZH-TtlIlV+BkHxoNAUI0%TU+E|8Zn%j3+Ga3^My>{9p-3VVP1Q z^2lmchjC5UpTX~5J%3S~?p$GSqgmN$hlu75_{Znyi9LrEO9zHUE5@;0C4OqIrX#*e z_e-tZZOu>+Iv0Xj)oq&-8TThb|?+W1ewOLqNyuV(h)ErQ8uwB>hiL#-9XY2CI z#!8<<*mh`?8D%7ItlBEo6S4KmbBW^390o#df~oHLcvb1^36|0Ldoe+~Ud1=qt=n=4 zW7;{aybkMMPt5Bqe{n4%2CKga(LsNsL8;IGG$JwfuAJ??ZlZ?Z#Z=nr@?;a9W9t$P zs>~HCUsv)F1+vfK*zMKFKc0MX9lg?QUn$#mAN{`ACLtXo*B_HTe(whAU6=YV&X&7B zKB=v+G2n3W>DcFn7F=5QPBiY<>!SXI+JaYiiZR|AF}}6Sk3Q!x5J?%wId0W=1~k%BV$lMt%17yY*fFuDrIOwX@1&LuY!y^0f0+T8GrCB33^h(76D|~98s4D+5R=Buu-0qr?v)J zRaHA&w)5=i+zVWt$i@qg(vRKN6l++c=R-qvxLiy-As*!Fo$<_ioG?(naipz$V~ys^ z?w3a^YL9cLUp?uq9%K1Fz6y^DEiv&3s&lIf?CaR5DmhViQ0an!w2$$=!4bir&m2{X zFO_bDp}fT25MSMVW%~AQz_m@|j?%i$H#{=YHXq`+6vG)o<#w)iE^Y&THSeS{7CQs&>hH$0uZNTx~Qn2+ZpL*|;%hr(?L9X4qAZ ztg(=y6D8FJ2R?14CmJIq?9pf&ox-u;?L6t-wyyk#;`eB1zxrm>E!-fuuVVY7ChnX0 zH{Tb~ZApW}@dhnQFFO`}$;fILGaDUnD*7R4Wya1S%J%2!BN#x=`uxvkkyd70-0)_0 N@Xr~1?}LwF`+wp)XJY^W literal 0 HcmV?d00001 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm index 91f29aa5..bee3ba09 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm @@ -3113,8 +3113,6 @@ tcl::namespace::eval punk::args { } set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) if {$use_table} { #assert returntype is one of table, tableobject set result $errmsg ;#default if for some reason table couldn't be used @@ -3127,6 +3125,8 @@ tcl::namespace::eval punk::args { set result $errmsg } if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) return -code error -errorcode {TCL WRONGARGS PUNK} $result } else { return $result @@ -3453,6 +3453,7 @@ tcl::namespace::eval punk::args { #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 @@ -3686,6 +3687,7 @@ tcl::namespace::eval punk::args { tcl::dict::set opts $fullopt 1 } incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok } lappend flagsreceived $fullopt ;#dups ok } else { @@ -3729,6 +3731,7 @@ tcl::namespace::eval punk::args { tcl::dict::set opts $a 1 } incr vals_remaining_possible -1 + lappend solosreceived $a } lappend flagsreceived $a ;#adhoc flag as supplied } else { @@ -4515,7 +4518,7 @@ tcl::namespace::eval punk::args { #(e.g using 'dict exists $received -flag') # - but it can have duplicate keys when args/opts have -multiple 1 #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] } #proc sample1 {p1 args} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.1.tm new file mode 100644 index 00000000..b38715ad --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.1.tm @@ -0,0 +1,5465 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.1 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.1] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -default error -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [punk::lib::dict_getdef $customdict -argspecs ""] + set badarg [punk::lib::dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [punk::lib::dict_getdef $customdict -argspecs ""] + set badarg [punk::lib::dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set customdict [lrange $ecode 3 end] + set argspecs [punk::lib::dict_getdef $customdict -argspecs ""] + set badarg [punk::lib::dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + if {$argspecs ne ""} { + append msg \n [punk::lib::showdict -roottype list [info errorstack] */*] + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + 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 [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "Option '$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 + #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "Option $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 + #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + set msg "Option $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 + #arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.2.tm new file mode 100644 index 00000000..16142ce4 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.2.tm @@ -0,0 +1,5465 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.2 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.2] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -default error -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [punk::lib::dict_getdef $customdict -argspecs ""] + set badarg [punk::lib::dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [punk::lib::dict_getdef $customdict -argspecs ""] + set badarg [punk::lib::dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set customdict [lrange $ecode 3 end] + set argspecs [punk::lib::dict_getdef $customdict -argspecs ""] + set badarg [punk::lib::dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + if {$argspecs ne ""} { + append msg \n [punk::lib::showdict -roottype list [info errorstack] */*] + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + 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 [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "Option '$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 + #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "Option $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 + #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + set msg "Option $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 + #arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.2 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.3.tm new file mode 100644 index 00000000..649f8f8d --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.3.tm @@ -0,0 +1,5468 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.3] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -default error -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + 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 + } + if {$argspecs ne ""} { + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list [info errorstack] */*] + } + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + 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 [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "Option '$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 + #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "Option $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 + #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + set msg "Option $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 + #arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.3 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm new file mode 100644 index 00000000..95d5c702 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm @@ -0,0 +1,5473 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::args 0.1.4 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.4] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::get_dict { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# } $args]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args call above may be something like: +#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::get_dict { +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# } $args]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::get_dict { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } [list $category $another_leading_arg] +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages [list] ;#fully loaded + variable loaded_info [dict create] ;#time + variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + variable scanned_info [dict create] ;#time and idcount + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages [dict create] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + variable id_cache_rawdef [tcl::dict::create] + variable id_cache_spec [tcl::dict::create] + + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + + variable argdata_cache [tcl::dict::create] + + variable id_counter 0 + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + Returns a dictionary representing the argument specifications. + + The return result can generally be ignored, as the record is stored keyed on the + @id -id value from the supplied definition. + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + spec-options: -id + %B%@cmd%N% ?opt val...? + spec-options: -name -help + %B%@leaders%N% ?opt val...? + spec-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + spec-options: -any + %B%@values%N% ?opt val...? + spec-options: -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + spec-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + spec-options: -name -url + %B%@seealso%N% ?opt val...? + spec-options: -name -url (for footer - unimplemented) + + Some other spec-options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -option1 -default blah -type string + #The following option defines a flag style option (solo) + -flag1 -default 0 -type none -help\\ + \"Info about flag1 + subsequent help lines auto-dedented by whitespace to left + of corresponding record start (in this case -flag1) + + first 4 spaces if they are all present. + This line has no extra indent relative to first line 'Info about flag1' + This line indented a further 6 chars\" + + @values -min 1 -max -1 + #Items that don't begin with * or - are value definitions + v1 -type integer -default 0 + thinglist -type string -multiple 1 + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + " + }]] + + proc New_command_form {name} { + #probably faster to inline a literal dict create in the proc than to use a namespace variable + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + LEADER_NAMES {}\ + LEADER_MIN ""\ + LEADER_MAX ""\ + leaderspec_defaults $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + opt_default {}\ + opt_required {}\ + OPT_NAMES {}\ + opt_any {}\ + opt_solos {}\ + optspec_defaults $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + val_defaults {}\ + val_required {}\ + VAL_NAMES {}\ + val_min ""\ + val_max ""\ + valspec_defaults $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + argdisplay_info ""\ + ] + + #set argdata_dict [tcl::dict::create\ + # id $DEF_definition_id\ + # arg_info $arg_info\ + # arg_checks $arg_checks\ + # leader_defaults $leader_defaults\ + # leader_required $leader_required\ + # leader_names $leader_names\ + # leader_min $leader_min\ + # leader_max $leader_max\ + # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + # leader_checks_defaults $leader_checks_defaults\ + # opt_defaults $opt_defaults\ + # opt_required $opt_required\ + # opt_names $opt_names\ + # opt_any $opt_any\ + # opt_solos $opt_solos\ + # optspec_defaults [dict get $F $firstformid optspec_defaults]\ + # opt_checks_defaults $opt_checks_defaults\ + # val_defaults $val_defaults\ + # val_required $val_required\ + # val_names $val_names\ + # val_min $val_min\ + # val_max $val_max\ + # valspec_defaults [dict get $F $firstformid valspec_defaults]\ + # val_checks_defaults $val_checks_defaults\ + # cmd_info $cmd_info\ + # doc_info $doc_info\ + # argdisplay_info $argdisplay_info\ + # id_info $id_info\ + # form_defs $F\ + #] + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + dict get [resolve {*}$args] id + } + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + if {[dict exists $rawdef_cache $args]} { + set id [dict get $rawdef_cache $args -id] + set is_dynamic [dict get $rawdef_cache $args -dynamic] + } else { + set id [rawdef_id $args] + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } else { + #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel 1 [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $optionspecs]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache $optionspecs] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set opt_required [list] + set val_required [list] + + set opt_defaults [tcl::dict::create] + + set val_defaults [tcl::dict::create] + set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + set opt_any 0 + set val_min 0 + set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + foreach fid $record_form_ids { + #only use elements with matching form id? + #probably this feature mainly useful for _default anyway so that should be ok + #cooperative doc sets specified in same file could share via known form ids too + #todo argdisplay_info by fid + if {![dict size $argdisplay_info]} { + set argdisplay_info [dict get $copyfrom argdisplay_info] + } + #TODO + #create leaders opts vals depending on position of @default line? + #options on @default line to exclude/include sets??? + } + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + argdisplay { + #override the displayed argument table. + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + set argdisplay_info [dict merge $argdisplay_info $at_specs] + } + opts { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + dict set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -any - + -anyopts { + set opt_any $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + dict set F $fid optspec_defaults $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + + foreach {k v} $at_specs { + switch -- $k { + -form { + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + set val_min $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + set val_max $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid valspec_defaults $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + #lappend val_names $argname + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid optspec_defaults] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid valspec_defaults] + } else { + set spec_merged [dict get $F $fid leaderspec_defaults] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + lappend opt_solos $argname + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -default - -solo - -range - + -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - + -minsize - -maxsize - -nocase - -optional - -multiple - + -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - + -regexprepass - -regexprefail - -regexprefailmsg + { + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines + #review -solo 1 vs -type none ? conflicting values? + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + lappend opt_required $argname + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + #lappend leader_required $argname + } else { + lappend val_required $argname + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #check ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + #confirm any valnames before last don't have -multiple key + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + ARG_INFO [dict get $F $firstformid ARG_INFO]\ + ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ + LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ + LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ + LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ + LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ + LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ + leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ + LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ + opt_defaults $opt_defaults\ + opt_required $opt_required\ + OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ + opt_any $opt_any\ + opt_solos $opt_solos\ + optspec_defaults [dict get $F $firstformid optspec_defaults]\ + OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ + val_defaults $val_defaults\ + val_required $val_required\ + VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ + val_min $val_min\ + val_max $val_max\ + valspec_defaults [dict get $F $firstformid valspec_defaults]\ + VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + argdisplay_info $argdisplay_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + FORM_INFO $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @argdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @argdisplay} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict $defaults_key]" + dict set resultdict $directive [dict get $specdict $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso - @argdisplay { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key leaderspec_defaults} + @opts {set defaults_key optspec_defaults} + @values {set defaults_key valspec_defaults} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict leaderspec_defaults]" + dict set resultdict $type [dict get $specdict leaderspec_defaults] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set speclist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$speclist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set rdef [raw_def $id] + if {$rdef eq ""} {return} + return [resolve {*}$rdef] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned ( + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "punk::args::get_dict called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table laout" + } + -scheme -default error -choices {nocolour info error} + }] ] + + #basic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + array set CLR {} + set CLR(errormsg) [a+ brightred] + set CLR(title) "" + set CLR(check) [a+ brightgreen] + set CLR(solo) [a+ brightcyan] + set CLR(choiceprefix) [a+ underline] + set CLR(badarg) [a+ brightred] + set CLR(linebase_header) [a+ white] + set CLR(cmdname) [a+ brightwhite] + set CLR(groupname) [a+ bold] + set CLR(ansiborder) [a+ bold] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] + + switch -- $scheme { + nocolour { + set CLR(errormsg) [a+ bold] + set CLR(title) [a+ bold] + set CLR(check) "" + set CLR(solo) "" + set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(cmdname) [a+ bold] + set CLR(linebase_header) "" + set CLR(linebase) "" + set CLR(ansibase_body) "" + } + info { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightyellow bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightcyan bold] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] + } + error { + set CLR(errormsg) [a+ brightred bold] + set CLR(title) [a+ brightcyan bold] + set CLR(check) [a+ brightgreen bold] + set CLR(choiceprefix) [a+ brightgreen bold] + set CLR(groupname) [a+ cyan bold] + set CLR(ansiborder) [a+ brightyellow bold] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + if {"$argdisplay_header$argdisplay_body" eq ""} { + set is_custom_argdisplay 0 + } else { + set is_custom_argdisplay 1 + } + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict FORM_INFO] + dict for {fid finfo} $form_info { + set syn [Dict_getdef $finfo -synopsis ""] + if {$syn ne ""} { + append synopsis $syn \n + } + } + if {$synopsis ne ""} { + set synopsis [string range $synopsis 0 end-1] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict OPT_NAMES] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $spec_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $spec_dict LEADER_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } else { + set formattedchoices $choicegroups + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define" + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + error "punk::args::parse - invalid call. < 3 args" + } + set parseargs [lindex $args 0] + set tailargs [lrange $args 1 end] + + set split [lsearch -exact $tailargs withid] + if {$split < 0} { + set split [lsearch -exact $tailargs withdef] + if {$split < 0} { + #punk::args::usage arg_error? + error "punk::args::parse - invalid call. keyword withid|withdef required" + } else { + set tailtype withdef + } + } else { + set tailtype withid + } + + set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + if {[llength $opts] % 2} { + error "punk::args::parse Even number of -flag val pairs required after arglist" + } + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + } + } + } + switch -- $tailtype { + withid { + if {[llength [lrange $tailargs $split+1 end]] != 1} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $tailargs $split+1] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist [lrange $tailargs $split+1 end] + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict {*}$deflist $parseargs] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {args} { + #see arg_error regarding considerations around unhappy-path performance + + #consider a better API + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + #can the above be made completely unambiguous for arbitrary arglist?? + #e.g what if arglist = withdef and the first $def is also withdef ? + + + #*** !doctools + #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def multiline-string optionspecs] + #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #} $args + + set rawargs [lindex $args end] ;# args values to be parsed + #we take a definition list rather than argspecs - because the definition could be dynamic + set definition_args [lrange $args 0 end-1] + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + # TODO - capitalise 'define' vars to make it a bit easier + # ----------------------------------------------- + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [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 opts $opt_defaults + set pre_values {} + + set argnames [tcl::dict::keys $ARG_INFO] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + set leader_posn_name "" + set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) + set is_multiple 0 ;#last leader may be multi + if {$LEADER_MAX != 0} { + foreach r $rawargs_copy { + if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { + break + } + if {$ridx == [llength $LEADER_NAMES]-1} { + #at last named leader + set leader_posn_name [lindex $LEADER_NAMES $ridx] + if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { + set is_multiple 1 + } + } elseif {$ridx > [llength $LEADER_NAMES]-1} { + #beyond names - retain name if -multiple was true + if {!$is_multiple} { + set leader_posn_name "" + } + } else { + set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string + } + if {$r eq "--"} { + #review end of opts marker: '--' can't be a leader (but can be a value) + break + } + + #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option + if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + #if {![string match -* [lindex $argnames $ridx]]} {} + if {$leader_posn_name ne ""} { + #there is a named leading positional for this position + #The flaglooking value doesn't match an option - so treat as a leader + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + incr ridx + continue + } else { + break + } + } + + #for each branch - break or lappend + if {$leader_posn_name ne ""} { + if {$leader_posn_name ni $LEADER_REQUIRED} { + #optional leader + + #most adhoc arg processing will allocate based on number of args rather than matching choice values first + #(because a choice value could be a legitimate data value) + + #review - option to process in this manner? + #first check if the optional leader value is a match for a choice ? + #if {[dict exists $arg_info $leader_posn_name -choices]} { + # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] + # if {$vmatch ne ""} { + # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values + # lappend pre_values [lpop rawargs 0] + # incr ridx + # continue + # } + #} + + #check if enough rawargs to fill any required values + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #required + if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { + #already accepted at least one value - requirement satisfied - now equivalent to optional + if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + break + } + } + #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + #unnamed leader + if {$LEADER_MIN ne "" } { + if {$ridx > $LEADER_MIN} { + break + } else { + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } else { + break + } + } + + incr ridx + } ;# end foreach r $rawargs_copy + } + + set argstate $ARG_INFO ;#argstate may have entries added + set arg_checks $ARG_CHECKS + + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + #exlude argument with whitespace from being a possible option e.g dict + if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + } else { + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + } else { + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] + } + break + } else { + set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + + set flagval [lindex $rawargs $i+1] + if {[tcl::dict::get $argstate $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + if {$fullopt ni $flagsreceived} { + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + incr vals_remaining_possible -2 + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt + } + } else { + #solo + if {[tcl::dict::get $argstate $fullopt -multiple]} { + if {$fullopt ni $flagsreceived} { + #override any default - don't lappend to it + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $fullopt ;#dups ok + } + lappend flagsreceived $fullopt ;#dups ok + } else { + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS + if {[tcl::dict::get $argstate $a -type] ne "none"} { + if {[tcl::dict::get $argstate $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] + } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + foreach leadername $LEADER_NAMES ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + if {[tcl::dict::get $argstate $leadername -multiple]} { + if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { + tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list + } else { + tcl::dict::lappend leaders_dict $leadername $ldr + } + set in_multiple $leadername + } else { + tcl::dict::set leaders_dict $leadername $ldr + } + lappend leadernames_received $leadername + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend leaders_dict $in_multiple $ldr + lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set argstate $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS + lappend leadernames_received $positionalidx + } + } + incr ldridx + incr positionalidx + } + + set validx 0 + set in_multiple "" + set valnames_received [list] + set values_dict $val_defaults + set num_values [llength $values] + foreach valname $VAL_NAMES val $values { + if {$validx+1 > $num_values} { + break + } + if {$valname ne ""} { + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $val_defaults $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $val + } + set in_multiple $valname + } else { + tcl::dict::set values_dict $valname $val + } + lappend valnames_received $valname + } else { + if {$in_multiple ne ""} { + tcl::dict::lappend values_dict $in_multiple $val + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $in_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + incr validx + incr positionalidx + } + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs + } 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 + #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs + } + } + } + + if {$val_max == -1} { + #only check min + if {$num_values < $val_min} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs + } + } else { + if {$num_values < $val_min || $num_values > $val_max} { + if {$val_min == $val_max} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg + #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + 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 [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { + set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg + #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs + } + if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { + set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg + #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + + + #todo - truncate/summarize values in error messages + + #todo - allow defaults outside of choices/ranges + + #check types,ranges,choices + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] + #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash + #puts "---opts_and_values:$opts_and_values" + #puts "---argstate:$argstate" + tcl::dict::for {argname v} $opts_and_values { + set thisarg [tcl::dict::get $argstate $argname] + #set thisarg_keys [tcl::dict::keys $thisarg] + set thisarg_checks [tcl::dict::get $arg_checks $argname] + set is_multiple [tcl::dict::get $thisarg -multiple] + set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] + set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] + set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] + set has_default [tcl::dict::exists $thisarg -default] + if {$has_default} { + set defaultval [tcl::dict::get $thisarg -default] + } + set type [tcl::dict::get $thisarg -type] + set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] + set regexprepass [tcl::dict::get $thisarg -regexprepass] + set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 + set validationtransform [tcl::dict::get $thisarg -validationtransform] + + + if {$is_multiple} { + set vlist $v + } else { + set vlist [list $v] + } + set vlist_original $vlist ;#retain for possible final strip_ansi + + #review - validationtransform + if {$is_validate_ansistripped} { + #validate_ansistripped 1 + package require punk::ansi + set vlist_check [list] + foreach e $vlist { + lappend vlist_check [punk::ansi::ansistrip $e] + } + } else { + #validate_ansistripped 0 + set vlist_check $vlist + } + + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + if {$has_choices} { + #-choices must also work with -multiple + #todo -choicelabels + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + set choicemultiple [tcl::dict::get $thisarg -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set nocase [tcl::dict::get $thisarg -nocase] + set choices [Dict_getdef $thisarg -choices {}] + set choicegroups [Dict_getdef $thisarg -choicegroups {}] + set allchoices $choices + if {[dict size $choicegroups]} { + dict for {groupname groupmembers} $choicegroups { + lappend allchoices {*}$groupmembers + } + } + #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups + #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes + + + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } + } + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "Option '$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 + #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "Option '$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 -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error $msg $argspecs -badarg $argname + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "Option $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 + #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "Option '$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 + #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" + #try trap? + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result + #throw ? + set msg "Option $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 + #arg_error $msg $argspecs -badarg $argname + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "Option $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 + #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] + } + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm index d70d657c..92b214d8 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm @@ -759,7 +759,7 @@ namespace eval shellfilter::chan { #puts "-->esc but no detect" #no complete ansi codes - but at least one esc is present - if {[string last \x1b $buf] == [llength $buf]-1} { + if {[string last \x1b $buf] == [string length $buf]-1} { #only esc is last char in buf #puts ">>trailing-esc<<" set o_buffered \x1b @@ -769,7 +769,7 @@ namespace eval shellfilter::chan { #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer if {[punk::ansi::ta::detect_st_open $buf]} { #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code + set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code #todo - configurable ST max - use 1k for now if {$st_partial_len < 1001} { append o_buffered $chunk @@ -778,7 +778,7 @@ namespace eval shellfilter::chan { set emit_anyway 1 } } else { - set possible_code_len [expr {[llength $buf] - [string last \x1b $buf]}] ;#length of possible code + set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code #most opening sequences are 1,2 or 3 chars - review? set open_sequence_detected [punk::ansi::ta::detect_open $buf] if {$possible_code_len > 10 && !$open_sequence_detected} { diff --git a/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.3.tm b/src/vfs/_vfscommon.vfs/modules/test/tomlish-1.1.3.tm index 8afb43d956b0212bfd728b88613392b2099993ea..83ab2c7ec49d4b6743c4aea66c4f080e870f17ba 100644 GIT binary patch delta 5874 zcmZXYbyQSc+lPlk=P-!G07KV^q<~1bARr+f10n*_UCJOKNXwCyZs`s|N~949X-N^3 zZjktp$H(`5*EfI6zOU>4?Q_noS!?gT&iE$Kbq18t!C{RYAqIC1bHfb?AP_4N2t*wG zEXx2ozGeXJ;W%hRI~TYJ*?Hsnb>nf}ui1cp*9>Kekw<;tjEnI@2a#-N!@$fB;gF7Y zD|ePM{m={FnV4ldqD7Xk*#ox4?JGH~)d+EK19&9UvT-G6aKgoVQa;>u?4%pdT*)g$ zbQ5}?^XNlnxLKzH_hEDFHyD;*g$rIUk9{|jm-`{6!#@IzS>;IMbl;_!I6{H16WpyQ zN|8U|C@JT80$a&mTkblQebH)}#7V~^))aDl7sUVZk>mCD8|(#WF1Egag|*bU3*sU4 z8&=(p-iK$V8PMm0Vjrbv`nJMoWbvALSPo#Ch2!z7Z-Tus>4!H2%h6$YYDUe;=BuS; zht|IQSQ2*VcJDz``h7)ldm^pi6u~$C(sU%#PlpG2)66|zIOJUpLw5&uTG)7;6x){kkZN8LM|pY& zA1c@2=B@~$GImcHPtT5UV8UQnOEBl8MY`PW4%SQy@-0?qJ_j#0e!f&b(PAL9EacAQ zEXRc8wy_tc_+ViObW{7<6l$dO2U?-hH)Fmhye_e4F2?Y^NsE36;qBT-gvUySw|(x! z+fx)Np?{*@KXW+fY2Mag=%%S%(cD{OGcvn0SrNYNW#_i>#72+S#fy=`Wz6Qs;A1V7>UHwr zxOL1P*NX3E#sl=nVH~80cDTjK7!z`PF&{G*q(ULA4$YC<2lh? zH>i5r7=Kjz%2(kia&4F;`&cpb;xXrY{*M?yZ*pvdR@A95R!!}bJJZXVn(^KjXVr%U zx=xiIZf;)HrLOJi4<)nL#==40_n);A<7k-SNlQZkv`%$zypD&*;jyY{J7FnT8ot7G=A$6g@OAa(fPvQ%+5y zrhe{vCAR-GNKlL-9EEz*dJg(06Z$qb#u1wWIEQWP*B3WBY0bgD*R z*2hY8GKRWzu?%%s%;x()w4_r;f4I=ELs#6tZ-w6}w!o!*NT8=OsPMLB3t|zc`q-&Y z=j}L`gR0XRl&OgH2V=3xVN=JJna7ud=#~Xransye=d3fG)Xs!DVY=i&31l4WRKA2F z+;!?QT@HPivNtkN4vTt{GY<|U18Rbh#J(}((y~YN?eom5k}>BVswdF9$?rUe?0AiJ+wT`%Pwx&MX&y zmY3`}8h!CH+z-kCMbqV~9+h-u=5-(XY@OV2i|_eC%y6Ni?CVe+7cE`M6W{P6`WIt} z`gL{tcD?Pl!#KSFU&ePm||(m zl$iw2+u92lbETk(lSc{hmOmh03L(u+*vE$Zudmyey%)C;r5@W^@pAhzK~%`!yE(%5 zCJ`xgi%Vm^JOwpLP=vCVBW(%4DWdl!T~=?A2I>FxonWnFYSXDzo9FWh?~jXU8iQ*S zt?RAA)OOSUAFZmtYRl#66`GhMiZ(`#O1|nEncJO~Vy1{EH;HUgO^^l%ow>GqBz#H* zF=@2gzrLTw6K{89uuUQ|mzdbxte*Jp5zx-i!?o-*+&O50c`mGW?vk;h@F}!F)crFL zLEwU?jpMRJZq>L(SV(7_NbOuFdMSp4tL^(I#Yk~94f_$F%HcD!E^GfydKLFVx#*D= z&5e;IL&&h5jeJ>sjbnqL&*PsB9o34QQTZpK`TRd*@1Zh76YhEF``DT+l_#mphcpOP zZ}S`FSf1}0V0Yxiy(06Kk!P0=0dNE~qSBS*G56KOmY58~ZXvenKMP*dLXS{AnTSi5 z%o3<%h!!T$ah6`TwFulEXVMlIfQRsSS&^;J$bJDW8Dv-o@pF8~*L2Lsyb1X5EqSvH z$;-Zmo4p|=W4)s+_!B-5X2jNWluL_b^3Fx5#*Jkjw$)LH zp?dJ1An>9{sNlgo`2lfV=mBpR!J8ix4-NGlW}ANs^Kkznnc6wYpwP~lpV4&ed%flC zr?eGwue{dsps3Bt9VWw-D@^1JbCXp0GHfDM^?B?^x)$nb( zd2A;4kjGHogM@_==NNcKfYZpZeOXRVSIRK2F4ZHNN0#UZ=^yArRL~P_i*$=$0)D#Y zt0n)SrFv=_|3pDiFYB=%v*@UhJH%7cm(SBlx-X2Z{{})O>F&@|IAIeIppAWPNzld3 z?0Z)i(3Txw(aX16ihfRRPF-bswrX3ZK<#<3kO&K~{7GCOO?5}&!qLrZ`yT(&V`pr; zD94JXow}Dsb)mN#8ynEx$H{KkP0T^c!xnE)d&WD2L|EmplQn~Q9kZ$JaI2At^kSB_ zRfos?-QVGaL$$VROt*vu-P@giDJ{g5svWIp=>_Z~S?safXQMJ#3d1rz#%F-ZJB zjKPoiHTve`o8XP=iA8$+MpYxBhHtNYm!8_w`p<=YiXti^rpJhS|sH!zzd zdA9#j03uM#Jo@b1sFUl#U6tLqIDYj{lAHuukA}IRE^^BQP(q3bTS18&iY&c!(C@8` zGVy&9!v0Qso!XUV^ukYG-o?J}e3336tGonXWQdHE76#sPF6|VPl8V(0?Oy7ye|$?v z<=VNv54yl`1aCIz!F1->L3Of98ZoQwnqQ2`uHnq-@U7*Ulsju2{31lWQEK+z)E2eu z-mYK`F?8*Bl_aT@b6?N?=*-@O+UNQjf=6_mHa|c-i1b!;@-Mo=B$V*XS8MVNTH8i(yG%1#kDjZg5mdc&M)cAv=Kb@@QK-d z(mGA>jxQ5mT~HBo}P zMJ_JCC6(r*1bj52ay+>{An^2F2jtEVm;H`C+Y!uW{aVj zopWw?JFQ18MfB>&54cRvhE!L!DVmFl(Y3d~8YNLT&wfCYi6*}wS+=)TF|SUzAs92E zpvg*0qx~X@fpm=4!=gb!p~|r7#XFC_s0}(@T@;EV7CG9OT(x6GrQ_yT(Cy&FcjK22 zLd#pS^tEs`=4#04UXBvSOpj5H#2HtNZ~v<^#E_y}xQ*B$*qwEOp?(h&iyQ)h;6WHM z0t_w-2Z*vBh0Y~JxLje3hEMvp~LrNMz*8XQJ?1k zgJOeM^okmN?8^I$1#O7#TMx9XpOL3I&(u%o&d}!HCP<|9wu@4D3HMPhWBG6|v|PR` z{4R|OOfEk*C|v7ErE~lxZw?t1F2IDCpqQieiDujCb6;<5{s+f#v)GS z3h=K_;jASZFk33U&9;8F;Zo9G`6VUNH3TT|m7^O6S&_9U64$8#YTzE&|t1b{3Nhf8N9UrS~PDw?wyV zbGgc()<lJH3O zs`@csLKOk{dL3<1@-WqkYuwL?%)L)!X1)I5uwmR_x|ZLUI|x$BjKg-L1D&DTm^)n( zzJ5f`vRXRxrANO$ZEn6>PR+cVSk~XYqad4WOKWni0;VM^C4jZu`=H-^0uwhaU^BVh zQgSn{jUSC|Zqk!Tk2{hzR7=aobWkwT0apskypDM@_qZKBQklKxw6dD-kzCX5(0qH3 z*87*7gLPdmL0aFKzv@M~@!AjEf!L$iy4|}djn70O+N8Z$Ndzu347P;#9F6X9L!b9r z>rG>)-yoHr^5i>QfE}u^-HGa%XzUxAmkadGd59q=lZIa;BMaBC=QnzwlU*HUDS*1o zTKT9ZmojD^Jv8w~raWM#^?cowr~mkY-`GI1ZeHLQmJ3^J+YwQ~6WG6VciAY z4@-0zZb;|uehR9dHu@Q9%5|c5P&uhNmfKPhTWV;4j;~&uO#8?**1znX*H<(4sK)M0 zeFJMM?^7|n!=*l!WSSY%Lv)F|<-h`SDw-2XI*2{}9!r0bVjU7r*&MkNSJSf%L{}%H zzaGgQx67Ybu`RE>k!g$#cvpXJvRm98iQs8fbopV{ulKaLbnL-CKA{FI66()eY!ms! z>gbFu^^^*gI#$?FTWo??X=Wb`uURqpQu;ou&%P$ICC9y!lCg??wx%X!Le+DIqjZY6 zVpd*9*ZfP4TPNQ7M%fHk=`hZ$v5xRJ^tgo^ZrbQg4N|y<_w0^^-7@S=Y2vT;coFWk;vc zPq$d0&#+d`k%_?^`ojEOacQ*j-Xp_S2Yp0k-Te<^J^{Qgvfi?l-`sTql$vHaGSGk* z#Yhw`tyWBny_D%IlS37lYvu8MAdk7S_AaFhtw=7bsF!r#P;GnFUTVaYq2HGwW5t9n z4*KPF@jF>i7UgK2rfve&$gxL=`az~F#&64Q{SB^75@L~CKO$Py4dP$h*Uvny?rl=F zM|EU0kLI!&*9&0mj%JEhF02dxnnh#ncfR{sLieMurYm%B&2{1;76qqmcAtIlc^j9u z;v;@>V`68c4*~xSUBA8dB2Jb?)LU3i<1G{KuEx%GW1{3>Va*1op$O3a&GgP~uaK<8 z5Ae~TPOtr$AdI1WtK;>cJoXFB|LmMV0kK&O4<@LWf&4~~8eS; z=o})@DhUBRqrOtfJWy~j2?>0I|3NBnD~<@%PeuSnv{$MkSqSK$yDEM7i9y~sNWhxy z3h70O!OTlEX8(%}V)$3{Ia3gT0mqdl6~_m|QjoyzKe&}53ea+0b+%Gqphv0zpw077 zP@WLnN<{(&ynm4V>QZiL2*82wN)4p(0i%2%M!FMle<${h{1<>NI+Qf4^mwH($zc!ARzTe;euNaaKQWdNMPoFRk}7l7@bW7e#u7w z5z?1w4iHfwjZq1f7qNja3akM!MR2=7ADH?*AVK%Hw*ddUpjiPc$YLx2B8rJX(n17q z{*OvGrUvZ`k$|J}RYK|^E=Y}HyGk8hrk4NJcwjV2`bx(XApqxlf6~7-4wzhd`NtLM z0f5S1U1TZ(mK7s`7ynVbW}=sh2vjdY0A#9vl2CA}iV!R<(FaohRrf*PQY0Xx_V-$I z4<*5`CBz_e86EKPKibh;{OW<~$`F9s{j2nrx#*RWD@OoBS1QJW3`{OJ1WeR_2VyKV zK>G?Lu=AT3Kq*%eu&aUxc%kzLp`fol4#-_81Ptl_mx6)0l}JF<_>Uq5Pn?KBXcZD8 z3xrkkg7;ma;8_h37*vG-7$5$f*Y8dSE>|G|b&LN}xZwSVB%n?;60orTtG~a7ajDHNWM4w|wUi1a zt%RX8+4t=&eADFh{l0Jhm~&s(xz955oZorwo^9y!0#qfyhd3%8V+9H1kY?y;Xf$}h zSeyv3&k_ROd<;ZOYoB3dR74uF`&#BB8eWn{Xpe3^gLRcn>~md(&#}0K+P)ZJ^Bb3E zng3ll_MqanfL$iKr-{$kGld+ng_v3uMrx$cN2iAyhxF<&;%oFaLQ}6xciJ*|>eIm) zTpG{!ghp1zM#iPwtUDx`&KT`)SS_p|p?D4Xk(2f4{qRL%c#wptL(xUaffi)pK$2=!Q{)CRO!8HO))Ftlw{BI0@pSF@2 z_b+){Vu1CqyKXdn@Od5XfSVa#r=|N;x6uIGkoAIvL5;rP;}nzUp=GW+4-f-)+NTdB zkqXIuzXgkGh#^zKU($-q4+lTKZnottpZ)@yohhNJ8^9H(d+V^{Pj}vynpAh|S-9e8 zYO%RwwT<6HgJR>d#{#7Ww`zLHw|K3L^s2M!ku##_AEr*HA0Nbi=wlI2iGLQfdD&jr z!A>Y~c`Liy);;XoM|8b_&a^@DvQ9fkYtn3rShyoU97D|MNM6XTo=C%@QQU{`>U2#) zS@=>y6`Cs+MS#rBU?!P-Dr+!({WXM?(()U(6F!FQtKyD8ZbEN+YN~7%?NNL`SW3jX zF!Qo|osSSt%IA*qw19P~@^sA+t9rIepJLgA>Q$24@yb_s2j`S7nk!c|EL3WbjDEF? zPXG4w5%G9W*_Gcr;|{7VJB!0>dAFQ@R90g?RSJb2jA&`xr9T&bcVzsHbrZ|8;GBxr z;Z5QdZ$=ER1l9EN+$PU^zjq0Ub<_6r%c$nnF+Q7mFg(dc~sOqL7Ho*<`cc zb2bl&H$Kxi`^zfmx;z+uAf}|c)^Z^K#frvC#kDw;X|&;JywR*{wDJ#0pPGZuGgBKJ zRpW&TpCXTM+bhuK1>$2YUTHC45^2rZ4?eXJ!A)*;w#nrLsJET1Z69DA%-mUjQuje~ zB;ecobuV)D;|kK6QMoGHj8{-8*~_AdtfVv_Li}m`M#@!2U6n0GAjGN6O4_Hm(J0}@ z>!-KOlDI593oj;F6uINjoGlCJn6W}e{BBn%I?2gVJ&M(z?UEm9OX;ThGe^((bb60N z1KSf(v3d?r=t~lEc3T?uGM9cmaU{*Nd?si6Tj;0m-XMkQ-Z-z~wL1$UZxbgCQ9DMr zCW*mt(!!yxLDV3O$4vHXo6{xagx{#1@UxS6*XuAwc#J0CN#?>;8M^Xt_+PC~!F$x4 z=@?pA&_-0}rZ;9rlym84{jgKD-Be6nq_K)|e%&{QD|T!nrN&>gRpeeMC^6*oS&fEl zfA4mxIge>h^*Ej2*Sv6SshKv|)@ZC*o9G>_`+6Y+a9)ZhVarVEmyGu($1A}U6#4wJC4gMG_;kxQ38+sa=41LNS zdXhL|@=cYaBai*Yt^+FAN@{9h95gFCTyrK$xijr}p1rcHSqIj(Ihw;vFn69og7s{c7Js#ie z#kb5gH4gjfB#w(^KJcpN`}Xi$P-71*k}iN){Bh|vi7>v2in{j>wKRUK=EiA%LfLBK z_xO_HTD4`1jEt|d<-7=#;JYgHghRpee57dpzo88n#OdKtXqZm7Jk_*I{_0aFOYNLiFQgqIW;wCX`c+A|9rK0Nv}kj zcv`UEMkIx{AwX_uE|>K5ZA-LM`E=XYm?m7dK(cKm*u3EaqhVt?AQWl9n?{)N-tDyfglc%f)rIPyg&WqdZt4va&!{ycNT(6rM0= zX?|YGbEHwU==e-lPI!HDq{~jD8@8U8u z+f6JPTz%IToXHb~E0Yudnh+}Av|qSjlSex@^~5U9uTD2`Oy1+eJblWqmjV5UXN6A` zyp0kMkoXwHw47Vms~q*-RcRwlSIW(jUZRa9c8ZH9u~#SH_5~@8v=kwg69X64v6)1@ zMxpR74zFQQDstW>II5oFYBTx=F~NY-Q185VltQ|NJyo?Rm(w?)u6H>_2kE@5#pGDgHe81s$e zbq_9`3FF|N$(Ed?E5TsU+wn-TKk6~@LxbYdy!U&&AaUbs$b8_-kuIIPKeRGr^fR}} zg`X7?db?-Q_gKwL9L(5boLLe!zaZE;*_FFRgAZ%ou7tgE*ZInjld$Xsi%U=L{oy0q z&hU`~zN$-?!V}LT+5;0D;Av97C&k-g&{akDW^b@|k|CrVyuLojNnU^cZoO=M_TNzU zQ1zY+6YWg`{-_S5ul{d&cgKj!L1K8wr%^dZDXZTqKFhXQzb*cJYb=V7)xF%Vxk?t_ zC7s$yTdA>lchsk^cGLg5mWU?uP$3?$7$5055$dL%jk+#$;PMG)$x<7U@RrsMn%T_^ z;4=DsSbhtCKQAO};d5VdOLzFi@)tdY%YCQMpCue_RtmO~_Lhuoc9dbgNpvb;a*fBg z!I%lxKBS=KYLUDNGIEDy!+?_PkmF^KBmG7K6-c)xxh(6~3pno^&#orvYnQ&i`jMXd zPNa7cw+x$&q*3{h|38{JJam?-WxrTRy|TIrDG)`q#GQFT|h-FY>QO+f%lJ_yXJgut6t zG(GiJuCYz#XQVwW8B-IMR!H~%Yg@UjFerr{;3(y7Z`Kt^hylQ4kAN%La?lqRkdmVX zJh2?WIfnz#=J3I809>{r;E+O53>HGMQ4&I+G6ZD^0i4anLZ$4~uqRg$s^_4D$3RIQ zE6~luLT5SmPz&1m6RLxM6nKH=JuDQ2q+;I@0nkA~Ev`Kj2R>zRa6TUcaiSo@U}C@wd>>+=DM_ljdXg28 zC^(PZLlkvN14AT&^3L4<&`MLg+X@vRcWJOx=m)jSQkr9cWQ+pn5)N?Jm;=6_O=Bvz z*C{~#8+3~>(2N{)hU_9W$Wb2PO4NauDJOO4kzzh*^gqQ%UB03i134>DvW`s zN*D_HDN-67*eQ{RkVp4I22gQ^8AO(1p=W=UeHjB-`GZQ-4Er)Q=#}!{@Eik}D8s@` zfKCY>*i&fc95Z!)9_1JqiE3Y$YeN&N)SddCX9K4zu+VF@ef;ylzEohK7wUV85vWzl zLw?8hv9wYRI;26t!vIl*gO1}UhdBv)iv#0TmXHsg(qO^70}Jr2#zNe>luj{l%TW;^ zYT>DmF;MDX19##D7an6FI(=$Fq%$LU^4Js#{SOfU(*y?yXSqM)KvWF|#sEwyk2uo# zIK^OLX;k8H!GU|VScva9brud6W{~5ePEl~6Q-^^H|7s!E6QI8i3mqX)vxHpPfe#S@ zG@jT%ul}k?XC`1*PY<-j;K0^RmXgf|xatKUs}p;>`_t_TP5ecYI|BTww}4zuQhQ16 zy3`eW8ZglEe+mf%8{J{CAiw4iNcKg5hDJGv&y12UM8QJ<+k}N&&h8-^Ec&y8G>RIx z*i-D_MlAyDQk06-zG@C(2Xn1(5YUW)>TLG4+Epa@*o=j~+wChiA{rR9V4*FieH9+f zDQ#*9gHSYo3&sCi{L#>8{_n}AL`iP@1KC>Dp_ATJq+D1aqE!yc@ZCcKG<|t50 zd%%EmJm-C$_w)VF@3$Cc_TFn<>$-E@d+oshoq5su+Pi^l?47_MFMF6BNXNol~yepV1 z$l2Ay1qSl6gLevi& zXbW}$LoDE(dO+=6Y()Tw@UBHfoa`+{M4T-g!Davkv(s-u9IiGtP%sSU;|2y@CWIGiO3kQmJQvbO>G8CzMvtn5I3CuF*~LYys}?0vx?V|y1HR}j<+V($hs z^@ooPKLPm9?_3XXg1`_6Kqc*W7$>a2JS@q zEMRt=AZ9mLDAXQ)4%EU146p;7@AyDqcMvTt z=*A5Yjq%BZz~1&y7!>s5_@Bp53pxkpJTyQY@VQ#sLqMl+fd5?JqW_8K+{NEdH?wfD zHUre=`!x_(SJ=r#r(M7-?45pHZ+fl+Ckuc{TNjWq)Xm8rc5>Fw&NxiJ(|*#ycda~k z^@%q8l{Ek{*AJD3qyEv~Z<&O;dO)mBXZKInah>f1(ED=;{6SzRDEK!jM)x<}finUH zYz)vESCAJNWM$z3%nxqC7H)13S2u_~U^q@b=emb0D{#!}RL7uTD;UU68YJ^Oora%! z!iSR+*u@s`F!a)Ay`Eei;6OpCS#Sm-*KdWI*&lH@`jQ_f!2bu;1?w+qgo&7JzT@29SaL;3qTF zd$ar_ac54K`Hc>oPUJhkC*JA1albF?Hu8!{eB|9|Mt5c z{Fbx7Ujd)Kla&P&Y9>4|0ivXQ?W{htg5?gr1Gc7j;A*aBhi zEc#Q|ZFH>s+(D_bI;sy|(;XRvzL`2{-gkK9f zi9)V6K-@k_Z9qWg0?gbRp3waG3UZoq{dR6A$^v)MX26i&V+z+P;U{SPSpClfF@;AS z;C!$(2OtV~Qgt?X{B4YXj2>{x|4IP7r|)z8TSq_6KNvjV8dX^Q;gsuNspfWpAw-@~=w_niPq zDiDu(xq10GxP?VP=R5g+FoENSi8C~!QgrYVmgzHFae1<*aZXwvO>74{DlY# zB#=;7Af@_&9Rw(s6W9U@1KGkeU}tzr1iV{=oh*EyARrOTP(Cl{J`0J--obUof1ZyDk1v!ENz{Y=9kbicjv|L=LsszunP7RF~ zB5)z9@2W z1w`j&eZmRH_sr~6ppGuCUcj>CobJL^)YSt9fOtfcFF3 zKcIG}PT$7f8&JR#BydCi_ksSNUi^UY&qq#WdRD{#F2>(38vnZZ`yVBIj)K!10Q5t; zC*pv6`~T(O-vtjy?v$#N{(#VDeCDI+zms>)*?72|BKi%Uf3=YB<&$4^5*r{uov6u= zwKlvw1mswNiJTN+P6F0x`U0Xqlhpk)*58ZL|My;i4)8^%RG&+?Ku`}$U?l=9nq2|Y zw{Y@;hf{bcgeMySI-tV#v+M*c$$|0%d`W(qlX!w%?19q&hx)5d24p{Q?LEB|kRm)3 z|CXokMTP&Rl>gS{zh;SaHWp4!mOy$7Hz>IC2Mq2<4)wR5;D$n{F2f1Z2hxj^ti=k* z>w)MAr{W|Fa0Xk$%Mc)dHz{B)N8 zYC!Poe|X-%_e_y~m126!arB${8606g??rE22%efX1KpB5_&+(o0 zlcFPBD^IBhbn~QUYz?yX0rEr_4?y$+|y{uL0_iIe+jc<_ae6Hs&F{AW{xqx}m~ z9iX3+YB5k!1_8MdkVL>G4~+KRJb;B3JY@iSxA;*Mh9}v-YRPZ_KUw^4YbPaSH(;WG z`F*b~1L@cgsQ(V|)aB3vRQ^_};dA&`Gl8D~f1NC&h%GlkxWAs=^_yV0sCbdh%gZl7=dqp z#2=WeGf=X!tPYf;=5|2o8 z5~<;rCqsof$oaIEz^|NEBlA>+zu~*wfniFUtLE#ea?_ec2?xvPX6;P4j4xN&?rfI@ zDDQoJNj>{w`?6$MT7y64m3J&CLU*F3XGmqmkXKN~K5mY!6(ze|xV$QVz-OEI;wp>S z>&G{_dStw&-wQ zm#Cwjr5?L9+AD?gJ;8c-fTXKfzY^Q1jpNddxw#l5?+)AR2LzZf;SVmsA`M?*jr|Bp zbwwIJV+`mwh%N=UYiwVYLAJf#|BS4Vs{yH_eDGo<{WzcCru}U~lniu&_#Dya#nO05M@%SU8dPHmn1YORG&hn2&o$Vzz zSHA=W!nU1xRMP3TFo_L`DAOC2$*(1t4Vfk0!ZKh9QGQguMqe1y)ON*yE`9ts^=i@n zhn;%?{R;+~jzY9?kL+iPFFcm>;V<^Y_fmeFG*04NXv#>tpBVdvYoASjFlvzcjRqS? zC4I;@R*=a-Q_2vXO}1*#Qn+Vw7FzGzmMuHeSOcx1;m0x)dVjh9(}MV15KWII-K5S? z-cyU7mJ&Vb*I}2oZcjdVjFG9#5aRu2K$x@a%ePdwgBe#O&UNFb!dN>=eJ?-Ff*Vqa z+Hocf8gop)M(B~JSW#79yU|ILZuv+Ld8qixvrPz7O5GP4o5!4#ZQPvMH&+(yxR=qOE>&_<(FTHMh-RtTnPdq z{15OFLO}UX{E8X8#02#KiXc!fOQ4d=3IBY24D@mV3E@}o4a^ZnO2+vyMi>YPcESh< z*AP(u+uq@s08sh&umbKTfw|6o`aUQUFeu_jV`nItFu_s7(IwL{{pp8@hFw#aADej9 zhE73EEnS5lLX1Omp2r}(Xt(pEFE@-j4wy<@ro>vHpMKcqRNDS7kKqZGxUUge9PP4c z70a!(<0d>F)Q`yNZ2mB!N@4x9mqA>H2veL4lcAsSXPMYQ%Ly?8mnu@~ryk`$Pka#^ zi&X7K?tTs0j2)}M)0wngim^2 zH#3pvar2Q4`M~y4V^Atf+@*`pwhW&8n`h$&4TyC}PxWp@lgpwtbJ2gn*D4;nvzmF! z7m0f4lR!maG@80ebB5JwS^2Jg0PjT!=XT!#bL!8E;x1U)x3UCMokiJu59e;V=Pq65 z6%FHA;cyVf4NY%t@n7|1s>qCghpt{;Ymu$ck`u9@l*M+m9={@suV{fmzq+sG{4Ke9Nit- z33l{4D0O=LUaI+>xS6-_tzDI;sQK>%%(Ax+X%4^bq2OOhif*~ZG68-dC-j0L2TZiV zfLp-Kjf`F(Re-e+id!BbGBLwEF1cyygCsss9D%#8OE_sZT=qUtp(-GIt|#W%-JaP* z%Edx{B6nPfOO)5ln*5W%9Jw7=& z8c;xeXo#Vsj_(I-wAG$`BpOQnh|~kCT(L0iqu!5Z#-nN{10Rf%=CXOefB6WHFX*sU zX4akE>MgQ2T9CCwVl$dMarA|Bk z@XE!fH4Y+gmvgl4_#S_IvWubbUghQC;q#;n*8X5DN#a(L%cxjG+btwYBSAq6S`a?{ z6svpPfR|$)x_03l|IC0r>-sFeg`&yKy4mL$v(GIWqq^%J>$Zy-qmN?!Da+X%W1`(? zhiI}EWV>?}y|j+=d%k339bS*0T-)}!+rDPZUgdeO(5niDuWaax!}m46L^D1GpY;Z< z%-})lEq}RqMLw&+F#LDSomXR#YEvXSX`-NA^n)+JGX=qxwv;M?&yNkCRbIPhhu$eR z&#t?RVW2jkP}H)408YJXq6EtBEx??6viNk$P0*b)Wmwd{g7$9j{&s zt=^3Zr4EUB#oFTBFJC6<+j3+kl8)Ni3u*GDaPLm+rQNZ8kMO1#p}7%x-}rO#C71Fh zaYs?o(XDqr9&g66ig{nI5A$T+WfkOS*PN@!GMm6CF>{f_Yl-0yHhA+u)?k60HF&yS zpvLW9^@H)vjUWni~Si4tR|Ggw6a_#o%rnhL~?QS5abSx{0@%8m5<11bv?Vuj^W%r@Z z0Wi|h74;)%_B)0Cs6tWC*IXE(^WKhb%M$t3W17(sovFe#vz?2HIP7gJ{fcqof#ghk zJZiiC7G3ti>(pwV#d5cYTeLn6FB&5ZIXlXi*FJTt6Y#THt9$W8ktM$1AgX}(y{xKP zPE?wzm!Y52^~H*GwYi8o!6%!%CV93;J4VPa@=_BB0%YWwX1H;&DjGZgCZaq;~cBLIpUUEAAQ_y3RDOUE$*V ziZi)&kWH+cH#eo_)|<++Wh>A43w!vP0a5hg{0@db+ZPxb;b_$*pYz zbsjvYj!+wCT%cTd6S4*?P|tWzL2|?Vj)Q`tL9WeBI?)k9PXuqt03L65>E399S8P;j z=}Ln)$S@lbLv)b|7X_dm7Asv{h;0u;z%O~W%L0RltVpZPzpXlzE0B7BnZJu4V!MW2 zC`}?FaqQ;dv#H9vXahlZj(4kU+qurt=B-ap#uup38?KrN)-5FjEZ%UT2%e2tN}Rl~ zU_Q(`{2_I^^PBC;qrRDR$#0({`4IR@=|=pIOghFTSd^;n!0mJTmkPEHoZQn+el-n=|_5Nru{eYzC(fHxsXK8&4e$@h?wh ziF{z@6~^L@S9e)bU(j|gdUtUU)b+XRak^Rs=cR`o5T+ip&+O9?XjuFA=VowLZ}p4b zq`pCG#~1Cf+o=82CnkX2_l5L8y)E<3v1X&<&PRcq8DVpl+qN0Q#eUA|tM13dg!j2H zhMFiLk(3s?R9v-W<1?S}o@sG5NbhuQ41d_7FScYaO`=A)8%+P8vi?*0GvPkYZdB}K ziCCK6%P=o>Q5mUFby19G3+(JS7uA~g($J}@#xiO{LJw6V7{2P_*L!j}s~|`>s$f6Z zLBt{xBOS6ozU~;Z$T^wMz}=Xud!S=1IN?>*nkt`GZOWb^g;LYXGkWFOrAJpbtG!aM zcfthk-L0ja?I-P{rUMU7Z5?rXI%`|Elu&Ez>#&=D8@&2%leoF0G_Xc!+9aK{dFDBR zXht~BvWt_N)sr+ffy8kIEd~m5-SBh}-YA6^xK2T#+PE>i-m5qM6Q#bsnHh5m>qtXJ z^_Crpp2y9?ZdZ36wy%Cv+P;!y$yc5rtwtQ~x^_b*Id}B`xc$M&tYEaQ5#!+lH zsXO=h!mn(W=0eE1T-g`Mm;Zw`_}N_98tnOFfo|sP0c^7bHlP8U7oAR0SvpQmw(qO= zAMbxZiPOfy!`sQ;#qn&O-NhDZG|lRC#|EeljA0=lDE{|(HUubfSOYt3+_--JcQ(Jy z(^qv}5X6(vZ?tYQmN@4`JEDBOI8hwg00Fo-TZuy%Oh|IHE-I_VB{@hm z(yG;U*R{zf(eTDxNAMI6CdW{Is&RP{zQ#x}c>%*)hmr2V_jUd|j%umQ{S0>ZAch5r zu(VBw^bB=_M_pzH7BASkgDtRcB^rLwu5M|RfvFeEyFb29c@uBLS>M>jNYBkyZp$?% z)o#-v_XCdHk{)I(^&#oU(M$ZFF}Z>s-o}s?c^M*4dxKIwV(Ijlr$9tu35+?H}A`#zIjqYwD(bL_aOT2`*6}vm%0;o zF#>rcpNxYI$8d_Exs>2p>?vuGT@qe}pA%`m9dpV;4yiRd^YCk5wqX>lLT-st^RyZw zcbZzKZ9&qjd8s3a5^rzoQ0;?+kkpRb`?B}2xyFuDz+s65Lnz&_uW8J0^t;W>r`Uw& z2|4e{$0xL#1~}!HysF51*T6wdwDQ*8E>rnH<)dTt;0WGLdq&+`9x3^&ihFW~Qb)lr zIkwakWQE`MPTmkWs0vnD<+-B)nOUrntJ&|lx4e;A(p4hT}MV~N)djo zvW_$DMcSvVs<_s#BDuR!#9eogK;8ZO$ydaK_U|J>ZRcsX*&ZH+e_MMU+s+QfDXb89 zRVq_39~qTLW9u8B@3KoaSdPzita9gS9eXo-V0Y^MswL`8{+h>e^YQBejGHgEuU3uH zaCfE!bn&kBxILgerXC96e1W}I!nN>ZRq$E)vH!G{cZAX|nMjUn1j^UPMVkffP-~e_ zw$8jVbfEQJoWpO0hcmWIQyaMhn`O80>Y+zCm(%B-ua^lfU`*Giac@R)Dj1LiTo|sI zG(h(c2BHW@hd!}%IceCF7z?e;tFesLLah6=@c$rSn?!{+erfYf^9V@zC9^s@> zv@5)>4<-_^XP(xUwdlHBM3`q{h=(ECaw#R6?h;tiM#kIaHW8nS4f@E@+q>=d+Nez- zaya%hLP~79dOTzskhibZNG5$$b#p!g|8o1?QH6`_4U_YzkKcb zbymaDc3S~Sz{f&>cKyHiwLksXFOOyhzfl3@vVcG=e9T;J%hEP^ z(JR-D&@0d@Ko|@c!AOznQBustP$Fd;e!l@>0U^jG2+JiP%Ox;)$}8Z>Gvdh;V?4pA zXfSCoIaBmNiefdq@rvRO?F9sc8KCL?5odfBI@FBk1oH9mN$tZlLHt@fH(vPeVU&K~ zZHB0Km&>_zEDJ*oq}X-CRUyu$BA#G!`ER?Kl+0+|Tb+&T;wx3%Uy<*Xcjk0dc3?P5 zPjf+)e5iD=J-}9PlRXvtokl(wg8MTgo^}N2TA5l6MVUl3-6OS*vDTyUb&k&_h|pRj z-F%M5Ur8bVxX8P)oSn3BKVC1n$jkn{F6(WR-5S3uUUr(6y9X8i-uTs_>{v@P z3c+GFhvb~Amrz`Bj6y92G)1GCJ99l&ebdxMAkQ@V1?8roeH{!kh zLd$@#PGcR$$UBGw7kJ;++BN@0IGI=CT^IqutOLyq0r|g;;s1kP{SXd^E5zQ`-o?V{ z_!t-mkdfnwjHHg*qj|k~^7kF;U}!M(WKIs#;9FJxSLLi(lvo*$o0x>{Rixjo`LEZC zMmF4EAoc52WmjR>yvDTnjdq5mKZ`Y+(+M4J#BLxsHqNfS-h2g=&Tkf;xShow!vQn93- zuJaB1~ojbw(pOZ+BGe~^7%O-e*6Tr_eW^_Tr$1dJ&8t7uFHVE3Cq zGx+c8lK(6x_^oRw@DzX@+>X4z*DdAaDsbAkvE+7dgpKrVpvK&|;CT6pN2I(`@Wy_$v~Z-^GMgEhwEi)hL%cKiCfg?X{nB{m$(m5@&#xX|A(}kQDAso_a{Fp-%yM1 z&f${mBfjBuStE$PeQ^?bb61E}t7d!k(|%j%wk)ATXoQb)=6Vapr5E1Q1S$tIDT(MM z6zBvjIsT(w-lQGw2shnENZB~t5U#mJgH>Jd-2@X^t?x-8Ulg!^h->V0XH8DACL2i& z$IG+)UD6S9hu!uLD+8k`qoSGJV#6WP4j{P zKMFwmqyE#C@!=*`a;4d|BZYN&8rsA%ndnE4zFuO9Jvch@WA z%Gj8o-b1I`1qnP#&v>7ZbX_>(li<33ZT%xy2mq@Ev_I;T&H+9nQotwu!o4)V^aFX& zMoT6fIa(Rw^H%`!?Uy^4DxQQW2Lz}co&cX)Icagu=GdG zZo~;7?Cw_Vn;GRXadzX&`Z4m7h*>lxYG}(FK~@|GO#uR2A&* zSMa%^4Ai5G-e?u3$RFDxtf1Gx?Okq7Fp-}5+_+m6ZXf){P(=MbY8M{;rI8$Tjy4Es zL>`7tC~C>Kc(oo~lENX*%_5JwFhS}D<1^Dk1|&xM#boptm=-tSV+{VJ`T)WK!#Dk% z&y`{mDqKQR+JbgIl1=7J#g2-&`kw(>e(+zxfQtGzOmdVjHEc+C_3bCo(wZ0j{ zT#XCZL>{`f?{BA!+$vK4y7h2aKL?3DQ2I$L`@`g@$Zy}|u6IJQ^Y4qb-^AQ7zxa@; z{A~{MCy{H2@AwTSS|XAjp?e44^Ost%yBcjd7L@uyhj zeDK1@wVg;NvBti1yiPji5xSPswmpR`2fMlKT1)T0ZjNsA;R7Ov`bF<$pY4HXA84Ik zf6Hwoet}hOd>PbXN@db^H?M#0qrznS!OhO+3-8Pc*F7*h$%jg{1oBwp?)suPr(yUg zH=QYFz`1`YH9>O`a0Fri_ZELrwf@5WPhI-SKK=CELo8E7-iPQk1hS8c{O)+xk1-nX zN`%G-)s*q5r0CgSdO76Z{OK_3QYGhupq$6=)jm{J`d%Kf*S{CKr$%_mZa+FI#fFCQ zIobGB{Gx~0=;Cq+<2!eh_t;2YWbDe-QqF4vNFvC3W#%of*YNE^<8DZ`o5#utE=t+k zC*!bKb3e|jhzA5PEAtT1)x9#v$2_=uZH)Wrs-|bhD$}u*+danO7u!=DB~G}nW`dP7P-nrXXAncW{+?0;;rX#fz%U}0%=nzIXfMx0AJ6uO0TvdiNESM7_t}Qv3RVx zggs&rXqavGi~MR64nxaPR7X)X1cX3fkB#1+TnKz8pZ7cafNY-_IJ-^?5ga`>C2c>UV&+G|x)-AYf*;oRaCWLx+hwsX z^@&K?W**6DOO{NQu?kFkUeCBgOgJ|dEHwO4u&rCvp81O9+LgDdS_Z-oX2{n-X1kOE zdRneh-8WrGa`s!do(sNY;zT2<3Tm3gFh0al3Atxfxs?7vZ`lF4tA`gacU*+u*nm3cDWxJ;p%WL7>Rmv_sx3gYpwogNPV<@=3!x8 z-()9CNMo<}R~{&4VXCLxt*=v? z&-HY5^K+rXL1?Wu=k-$f`mojuf;Nw{A4LBSyZy+yyU*a-H}mI%I&UD#rXw; z4~j$FWEMgWijr68ExdK6y5<7~Bf0XR>W3AIB1U|SiuJjV z5=qmPt}XFly(Z*v9~kl_)0e!YRs3K$U!Gq5PAg!s8|JFmPbEPHJGrxa;vmyu|h_K6+#FmF$^7*()zx z0@yVTH{G`)F+~Om@^f$ZwiyLl)67-d;|R%(p-v_A$0&RdIiQbWx&>yAtjGRP-t|7Q z^U|XmI<($q^!SbekBb&&i_nofB~gsl1=Ib)@{J%=5AHwFRiC0%C?GJoG}e()cgH!2 zX@H8qOW(nisfpAuT2ZECukd2rXAr?ufw`<5iI8to#;dvrp!}j9zh@D3Yi{oYb27h2 zkSSzXac$K*5mr*dwFBSEr|I^YdIeiSIEEp9R@!v{hkJ8Ra4Y}KQWvPBr z!HQz)@OMPM2en$fef2e@@Co9KF>XinYrElnw@Rf)RWGc0KbeqnF-F69Of&bo-am=- z9v8YTPvq4T?m27NcT_pt=JkQg?nS%_K}qG?q{kY{1uri7m$>f;?A>)eTB~(zf3o6s zZ>E~GN**n%3GEe>ls`w$Kc28nff?3<{p3#PU6kp}Mdpp0xC@I2Ht8{s7Lstf=a@-j zaVxWWau*{HU3gdJI=6N}SA4`XDHc=FI%Mm8(=*l8m$_3{A%&h?CNKjvGKuNgQM4lC!I`xjrZB_ljyojLaGZ;dzOG}B7Y z=X23*Un;O$iC^Kqm-Q+_1eA8 zh07fgjq%a}XiXB0GzTP@@|Mvm^MpJzlkA)q(W6}SuRI&xK}$gOCGIlKTV(So)~0z@xvT4|PM@;D zxooc(^oYXdt6P<)LRvW{E9!ETzo;CJv_Dl{+|=9JpcV+u0xb3tinmuDl0Vwrc#`Yvj6WK~+~QP5 z5yTj~D<`(+(y~EZH#bVhZ$j5jc4Rr=|DmGcaMQ@{vx+CiRb0V^UTUF)uwK&Q*#$T1i$ySn9y?KF$SS`hn?4BP%1vt z^jM00a=VS(luJ`?Ol>=EQnzPSCpfy8dKcxEv+(?3#8gD-ot;>v+fMT9dzdMc{ULTW zA#=q|?7EL(R>#kMg$zdhDwTvY_FgJ*$;So;%3PlC3!I6`JwCI-Jy|btIBiD*xq3U$ z{%Fo(1MKpL{U~0Z)GR4uRB_rtKt(LGO)C|jSnz%*^2>Wjd6zWVR>eMRYwGy510uL^>{;TlOL0$wm(jr%O{O^4xMaz+mD{*@BC$AfzVy z)Yit&k3uKWkWg^sjUUmE6Xu5H-B~{**6!`)M4cEAzHjw#&hM%9iZH1Xiajj@cUR!A zybaC)Muo#jA~649pqc&23fMUgey&7ZNn-vL^aRoRuio^s*8Evi{WgL{uz_sHdMk&}R_jhBc-3e-_A3yK9QWp97WX zRGMcot~^EtI9aV@36efKvzT+nW;dKCTnP|8Q3`k!>A&8^`Ol>fI}3>QnL4TVEKn`d zx`~*#74w|Hj{(^jIj`$bD=hg?>@z`FVoYy?Q`r3BTb;1M`C-~HNV%Pgga+b6l5BEx zgfp58&!Z5!AEh5ql&NsoaPJ}(p>*N{VqKr6Oyd|a^d=@gF_MlFzs=w|NnUDw!?1A_S zPN`*&+$+%}%GA3T%rFw4g%xGJqpF!SM8hmQg0=lFg|1$5wM-$0e$cfC<8j50=^j~oiS=E-UD%7r-Q?TC?N`UN$tGNh`dO+uIs4KE~=(mH;t*{4UxGs{4QKN zH(VIuponIVb=5Xt^rHcF8i8ndmp4=G^;S(R2qB@emHYDb8FwW~YwA`$flCBxBGp)Q zK8v&{e3Hiz{w>yzh-HsC^jdJ#t0U18uSr){xy7dWApc17u6DJcAdV%Sdh2bEfwC;Y z_v}G2oK%`o^F1vN-Y)hX*Kb%gmEpX^stZW=@G}X^`Y0mGp8e=I_o){ms^K_IGx}9f!!_IUOZ=S|+){BG78GEao=qyK z=q*Wi&o^)LG!X{;$h~?6-7QpiTdeAa37#Q)x9YD<=QH$Hy^ZllPW-gGeeebI^@G(< z%L<2**O!vMvxMD#X(u;J{B+3VN9He*J4)a;}hbl>yEAbfe#H9O=gtT-ZQX zPKZZ!;GSooPr~bvRU3@bFV?X+v(;Nf?1cdztTpJZ%vCZnaimFEZ7Jff1Lp9MRm4Gi zdly7`ACd{VhhnR0h}eWoFggJxy@;It@!6^fM8%V9_s->b1U61C#0Uu=4Ib>N+k1B{ zg(G~qMG(YznsU?zUYaQcyTn%TZ9xX7oe)>ct<0NjHk{c^O&=axU0Th|)LcxElcq(L z=`h2*exaj>#YQ#um3CmoPJImtHG$HwP<>NA;w#BwvQ}R1PgCpC!c%M^YyJGnxai*u zbbI`yF>_-ESV!t?mJ2N7W}6GqTU8G31{Qmk#Fa!-$|g4@nQ*VL=hvz#4H}r#J-VVY z=ryi*#IAuJs(dRo@?nJ9Lnq=@>h2nntzpZf=I1Co+0lXtvQgd2p2XSse6qKd_!5+g zo%%~3mEZ|rzlqYG^s`w^h~&A#%6?HjM3j75FImJo$Dr)_#YitpcZ?BF-G1Y0@>r1< zLlYf7AD*XUXP|x?w$Ih$DyhM5#@pXVCtt|UBhA=K36pH*Nb^$gs&u&a)xF%*mg&uA z!E(pA`^NgFe19eRC6l}g_NFIR`rCcOR>*hAwfYQe@~CYz<3|bX{10C^S!Q*TyoejQ z^={~eL<&|xzuv3;u`EwQV{H*X9hBNNC)ZaLrqZtk*$EigR2L7V+j5`F@;g{&r6MPD zHR4@Q+IHcVGI%q*aU3|2^BPtzari1`u^Z%cSDkt&E@-Ye!Fo+^|Q- z8!wg{lN#x*^k=*`S1vr>-!-`@?(NAc^}bBjB?I@xTKkUJ+dL*N9+P(~hn0eY&Nkr` zd|w!<>#~8Z&e!BZ^11Z&D-&k-M0gR;hD~@bAxK7g{Q(d*)d1zz`IAuyc(nCbHg$5J z-XpFao|n7{az@BHja9ZAo=CUM%oE4`zwX3rN&;MG0Q zUuGHRY4?8hEfk!c=e*cqVNZ@|fqHFL^dbmt0U;(KM=Ix{%-u<>!{LUhgBupPlm~cz znL_EVuvC*J`qqR`g&oN+KzHK{!IhTcS0kovt0huMAaO6Ks1aA2P3gBMFRc<#*7L2Z zZ^wme!f13hZkPa1VBB|}egbT0tqs{Ob!cqz^$!>z|3y+c=CM)|$|x`V#uva5g2taD z$;swd?Qj9{OyeRZ$#aq zM%f>fnV-1+bpK|fK-eJ1D$RhbL(f=xhb2chTX)8*=5?h$PNLx0fg6oJ+x(;yB1=Jm zq3uVVbV`$P>1tgoRr~A(1B7BXm9nSU-e)uM+y`%fDSSsPLEbqpQ^m($nHccSjy=p_ zGr0uytfOI3mgykvka6^IVjT<637;*I>5SpkK#@_L4bfhP$v^vwJ6B_lCPrgx`TVXo zizDsW5m&v!ihZl}X1M1^6f!PuoO?1`I9)zCTVk>Iz+!0?Tx0R>MOdD`XqS~dV)4G#62E>jM zq&vkB38~54U67&8{g(Z3Y+uV8`3G%IwX(H^TU*;AT-%A+sB6KtyZCS9HQDD4^Q#aa zJCyPaD|j5)-B_yjQ%~>j0yQUCi#`*gs!8AQr^GgwnTfIPPAuODGTdk*+3yzFKzh0; znSbfMpPx;d4c1}71q$)_o`e`Q*PFs$WN&%E3Ta+*ZSBc_La2=8^i6d(j41rsAl&r3MmAQvr6N{l63%mtY4Bzcw zQ~m()p1bp|QmNDh_5r|GNPWuMN@~}7d(T-f2EwrtmALyZ zutygGcqR_GV*$AD#_sYhhTve`HSN^#zHQHI_?3Ot=9;!Ot8hii?F3_xj_Q%xh?|6Pn z@jRk)yZGRcqQ^|%qytbof%ZrJ?CDP#{z?zvy2KI3gW1MS6uNs9MMo)OSd<~_uBGw( zg)*8_1TMMLR=JP#w_V1(A$PC0o$_~m!8(_~M!B~{1gTKQYd4&-M`8&}(7l<6gPBT= zOw{y*-G>X;z8F*XImHU$7(Kq_Y2%C${k*8CPw3^eHlEwfB*tLL3%QudFY|Ibvyw`# z@36JEew~WhC%!zMgtd=r7xPdIi38z z;}24P%IK6Ays%xF1CvoBFc#`(#ZpzO_+qh{zipl*p1m z!GZT3_>G(1ip0TmrDP^*b&&Z7R+FDu^e}-rAjw^+Rd9Np_vjYE~d%kLn%S#dT2(8T`{`Iu={)daIr3a70JJ^O%z^gDWqJzyr%bh(IavTl zsRKC5io;iCVX<0gWVmAM`vGKurOpMEZZyq5d#azF+-7%HUyuF5jn>UeX(lyvoU*Zq@ym_Lvp3q9Zxmpm z+!wM%RVjEAr?_fT)fwu8H58s^7sN3j%v9?F{Fn}_?WOEifd>APvi-GZZ#M7~E_|!x zb<0H0O!&ZItp_Ut|+H`rE8}AXZ%K&rwWi=`% zncW?={Bf5E?K^z^>W!9L9qK|lGq$K=P^eYWSK>?jD*m9Xc5z1ngf#JtdxM*RM7Q0Ml=`5^sCugV-h;e{9L-uNcAs0% zJnar=$Ltc8B_+TPInea~Xx#hmzxcmv3y_>&KvV@X8J!4CRv-*VYHBg}=`(lhGjl3k z?bVw<8<63^=m$XIRB$y0n)&~Q8lM6?BQ`)k{srICS%9K!TL!(@FA1XnaD>2hHo*HI z_YwkT@I8O<-$wPc0De#!c0#0c3=e!?uKaH1JX^0kq9DCX>lg!v3ri?TVs&07m7+A( z1+J$@yMAmG{h@KCOFnMmGCP%sF--ib4~wkK@{o2&Zgm?#+{+dnLy%yW3@&AMV*To3 z*GxJl#cwigMQ9ms8@bH~lE`Rr79DMEQ_Wo!8sOFx*gR4nL z*ypWGx=(rJ7Qg})z=qzRw6fD@5`Lyma9?j4CrSX{o9uVrQjzFAztCZSqWhd#5gvx! zGx0?1(CjV03CivaMK$OPg0jzXlf05sV~i3)FtTI`_WH7j35jQ3rfyPhbO(a1npdls zl`Dx<3*?!!K6zi?lrdlnm@L6;Fms$oJup;#L2K2sWBVeYgOKqJO{X2MP+q>U7f0Af z0{ucKzcagM;QIRT4HhQ+P80_~z#m-~oFm|;x|+t-;r9*3ju$Gegc8 zn=TqM|Dkxjrxa$&%B#HzG5<6^;=q@n(*Ql*4bwm7hn$C4U^OkM#6|I ze-cc`&yjiuq?wria5IuMP2$Rdj9uN^Hv?#W0$KAY2UFLS7chucsgoLe2pJzs_?2Cv z2qxuute{e2E3CTwx#LU?0M0{U$jqQDzyo}f<{#Z_{GEp%LI1>`M5_;LUyEYV9Mx8d zW6_LSDk|44(wUD^AlB80($(mD$)&8z+^wX`&8ecvtbVos>MJ(QE_OYoZZ%a^4n+4B zquAuX1kbm%B+K#uavh-k(R*p<(EpU;X{`9`EWS@;37Ciee=-kH`nh@FvPT-NlF9^i z0*^n|0!yoF|3AzT{)Eu42ZrFE&iuAX*7v6%Rhun~y4(m#2LR!SOk%LMIt9s_S4xAOb03B% zv_BDOeB9_<_Z37~r_eBL4yN${J511-jM?O^rL4qm8R}eb#3RnMV;F9W#$6?StXs5V zO4*j@Z;7nZT4TD9w)f-mTqFh4d(F|hfBdS;z-SA@+R!o_SZ6+V!cicd* z8rQ92;NaND^9&ITka@(Su*pnC&$#F~W1wTi0s&nW5Fxfqw!`U3d@j9_&N$>Sbld5i1*Ox$@^_VLk~ zhyiG-^06Lf;>=Y+GUWV&EI~e;?>l6uXj_0niTcoD z%oEJ7@(p>k>>vkkj+Z@lu{5$&SMo?SW-J!nD*aeF)XHeS_=ur>S>tadXgaEP*m+~F zr^!FVuVK}=l6jAYc&&l1O}&>njZ+Qvp@Q1CY#P&-wg%YQZnU`0InA@Q*yW#4GN;?tw3;^es$EiK90Wl3CXx5E-i#TmovY~nCfaI2TGXg80Z zoAVr(+pzh&dhmAmwLGtLSG1;Yky=d(x0t{G6#Gu_G{*5DjjyO+XC#z*PMiI`F?y|t zSlJ!zggZ(oq5{IhyqRxC7b>pChRl%G9xpgi?O$v*)>ifs;_68QqZuy39$X+UMZ4LQ zwqc7vFo(FJF%)vILigZW#Bmsj;0tILZj*e6NW4|FU0NmCGU?0e&|Wc{1k=cBV#0*a z>A1>bGc{wBtxHRh2MqDIXS;aQjckI1cZl9ZT_(ZNatRjOyRFvgxJHgqrm zN8b@9@O9?t#vLX{iIj=YDFg>;6nfvuCo=mJHtQ*9_AzNLG57;X4 z`7+dNGX*xy_FBtcs|gRa8f&(YDIqs4@GbCUQfV0nh(8dN3=ctlL|rEwBMtc=p+>Cp zlq!L|A-&gpT23QbO^T_W++a=$cmHW+(mSaOS87nxCbfGd>B1??LS}>wsVHzSCvQ&h znCLR1U(XDMsP)>DwUOU%nPAC4YL_=SDuH5LY}QaHs~N8!#u_zVWMIh{)*#aCuSb-I zxaLvP&aH4;(+NpV_X*rLz0g5d!rNH%c`$^Rw)Y(#%ZTs0LLOXt^2Y`VdHQx*Lb)$n z%38CtQFA0U<**G{SoojLI@)~}m%^9M{w$HZ@yv!kTJdZABgSiQ_z&l=Rm&eIJcCI# zvyN&hbFJK2+7bPg$dK^)pL?Vo_TT57C%**sn;&L^Kg|w*Kmu4aoc?&z`A;Wa_2%u;dOj$^R`d2ROc8>o;vJE#L{y<@pl9YF$<(4%WVY?LkfM z%KxvovjD3)i}v=RrKD53JC*KIQo1_?q(NyxQc6JSlgL*YA)GjfQz z_s+sDLPD?C4Nt@Gp7Wr3*nz#oy{!qqXb1>OJulX>xXDB2-!icnj0# zfV0&gitYiMAJiQ(@3#O=-B_u|m8W66mJ^e#3{bG%p9o*(AAO8F(8Er(M#+0`<1yDm zG+i4aI<@E|P<5#F#NM}bPIaI^M%+=5o^Ac>VNoeKmKfg-z`x#vO+b-o^_5)CXkqah zJZsPc=hzIEJ9kXB+QK(X$znXE7?yEgIbm zl%{d^s@BX>be^*!|A^}ttA3ltBR3~^pG=Bw_8k8^-rF7}CCx*wI>jm;XCE{yF(cXV zSKgjhSC46wD(w5i_!#r4eN5`f4c5}Y*16Rr7PZtj{OXLtH4AqZa|eaFL4}fyQ_Pmk ztfx*l)9EzYWEa5@BXy@rwq-HL!-ZGch?sDMGERiyGy;tZ$B3| zsF9<4iOuaVqvN?t1)>W+mV?@K6Wa=e!G%!Z5JOhX|eag9@WDAykeNowP<;Kf) z=kJ)sYPdb+duCaX@;q9BL>8hnqN>hc!?p2U%AFk>)7sp?ozggdUHkFx_HOp$P<%AF z>@$|S(5*QmZ(u_*0vq?hC*tXikN=R95LZhz)E-s6g<_>H>9(s|4{s=m4CgW$GeD_JTE8VZBW zqgJ!7j~D<7bV;hWLTds=^Z>D=XZV;di}f0dDlMvlv(+q2Yis(H2t#rrVzFI*GAz6a zrMmDz{uPO2Tp{xOpQtm2U}y&9gxI{9$iu>EY|>EB$~>&Fr>S?zrY$J4?LQiG31v!C z;eL+gmCp;m!_Qzt0j9ycg%AG{JM&EfL?xz9>#S1RzCi86qyQt|0A+JF;f&io`$g74 zcha6lua>E*)gzLu>Ii&VHVNqcp{cvn2u!nZORU7cnCGg;&SGVRg!I+zNXIxFPLhvAnIoyoi(Xw22L{u)icT zw|#&phS7)hbIKq$C~n++6f}YoqicneGgF#^sTj`rl*e8bVjXn=t3PuN{forYAlUez zW?l%FG2>BnS)~KpqtDKFnYF<6tKcLGKHkbHR5RrcvYp${e%%pNJumXIH!%|N4r+b5 z(L5$$S~Lf^m3f{JWRF>M4cj4A+lxDp@znKT(8Xyj&}886#>P~}RAsuU85B-CI*Y?T zEwRg@3z|3K@cF0rMq41Vjx~()FQeu}KD>oj_tFGJLJy7A4uCJLEYv7AA=00%Y zl8LKBmqWJ8?&`N&*vY+yoA|_MvXUl2sTd+{#Zld!7#y=Y(%qN+6u;Cs);V^N(NUVC;iC;8($GIDN9WIKBaWyoW7`fA`Gq=eplX1y2RPzb>~>{}r@mosPHWAR92 zZ2@PTz2;*QTaZ)e#D=+39#BSWQNK*%jn$Y_F5be?loEwGzdO!e^-8zD`*h4>yRC(4 zY59Do`R@;P*Q6=WtVGziE!fhn7pXr;A}c$vBi@s&nWGu>4x+|hh;3pfmq~9S_`0GD zz`@*)3*#?%aY|@0dvJ2c{2?2;PT0Fw#6l&B9o~4^_p6mPZ(X= z7Rz4E9n0Gz9@)Dr^*L!GjIddQmu7Zq25#|wn%t3Iw{8iP;ti~Yq*9Rwh%cO|WVc~s` z&eU=>kMX0%(X2msG6$C4v*GZyTm4E;T?H@880gW2h4+T}jBzirsm;b;PfIpIGKWkl zB5Mdr?z4FB6W&1j7e{GoPZAR27ff|XC{S{}KTsO*FcF(&q~RPe$60?GXy4(Ruc0i9s(<5}M|RAytXI2B9l{7XN$;4}UKg}T=_|vs3bU7YHkcq7!_V-emfRIm z%wyk>R7cumDD7JOXGpyd0X>^{hF|x6IdV2ycRlSFF{%jQj*L-``2l+U_^Q!^e zA7Qfpe2?j8f{VZAKv!4G8!>WL6HLhMGp`PBQwFrK`NQn{jlg82Aif-eWl=&C?jXBg zy!ye^+(a&Xi!Y7?QYdNk{R5W=WT6YCjGuSTu-e6I?bBsxx(Eg6JiLj=B}^bv`IMGD zPz5+s@$`g+B;K-!1vEef9Un9|W+C+}=2Jbao`>cfAkV_EY{bw+v8cwst(PM73*$YEhx53z*3;gE(tClFA+f4QkGB}um?=fk z1SgE^x_j`x3s?}BM1;muhzHI&EWOR=Erc+ch@OC-vp^!1WDG_c7Z~z_1hcg=4$v;h zWZj6)B*x#D_KIG8Lf&fWfCJ}l*_V`k(jUytyfz;Ew(4Pf_LfiI)GGt>JPnO7yZmz0 z7+P>X!Qm&tJE_x|8hKTjMrb|5EynkpV{e63J!yF^H9zxqXW7<&&cD7}ypx-!SGw-h zabC;Udo4Sp?_LpB>?&Q3u&^^3^yf``j%Zh}<)uEGWA>SodZK`yGfBMWd%JB5i3Q>- zM%^5V7>8Y%`$?Va_ageMn9;?bxtA6l1eS#JCn!x6mbs^Vr$RZ~&#oUjb+v2?$k;9=BK zvYpCqkHEME*%M*lH@BP;PBs;*g3z%zVO}EKM6RSLIpxRTW7H4n2u^NAP2`NL38mQh z;yy#7({?O)sJA&hfu(M$v3T{-;Uf`#ERr17EgTjkAz9iTH_{iDYDGe#W}<84>RXh^ z9$=-e=8S?Z4Ec6A^m&@<>iL+1^>C4Jkvo!;*0a0qwZtM7UxLGHV!}!TrAsE(S0{|e z;$KsH!llBcRu*!SZyUndn=HMOdvEsjs|qm^4h_#Y2F1efAXfwtfy*ZJ&RmBB;P&c1 z3;^(BWBs3Q^LIRKDSaUfgA#G|DqiK2y^w{Fw%B!K5tc!0vmX#Be zrX7K`FqfFlMFdD-da~EgOVQ{*YZ2B&j?WeLv7ru8yO)Fy$AylJ0C$?Ao};)F%H#}J zQ1nQDFe^67rQ{yZ1`<3K`4dfOx7$bbRE-s$Ro$+yI@X!`>I=aRgsZ;mEBP4NKQXPS zktm2PeNxe5SwJl`9>qbiV&-VgC>T0c;CLE+$d5~Zv z)MGcmMlg%kv!TRFe{`2?JQC+=QNRiDZOr4oXcG!v=I1Gm?#bPbi3Z;Tw)*K~Q0q2( zM%?(mD-zL~o*tt%KshHd11?ogv{NDQ+zgmbO`b3W2q*e$EEIAjsap3RqEhE0Qrs_QYw-NT|u_1p94dbv#z zBLyA<)8dGoyqM=hXIGA|oAHEZy_L(4gj<8anZ3>ODdEW~7uvXc=~m1Rp@T0tMzH(z z`!kSO2o+#Qzh-UHLI|8hStI_~#Q(?1J}yt9E^Y7qweF4j<3<8d$L8CM#@_7E<_cb% z{m21d%hEDtIwJ?z0A3jp!|~$9X~?;=k8*VFgyR&lxXva|iqmmwSqXX}Z0n<#+Va#HVRu1IZ-Kp>@VYM^PqUz~=`eke-VHCwsc~!Q z1I02ef@OmZ7X^QCimGzTBf~7JR64BHS*_^sE)_I@A|7laFy4|PMBKivZ5q*}8V-kC zq)RY94v-EXDhc-RX*jV@CmQyL!)8&u^;k8+;$mr3vq`W#VMYbBzJkt#-p>9Bd_LF1NRFQtd=d zDUNQ!B^q5t%3H7dW;Q(@J1|f9KLcKFi86?(KaG}p{rrHDc85N#` zW3ai$27SjmpL+NK`@F)EBD9_#`}e?jzaJ4gzuD(q-Ll)H zE(p8H>3Xbo!-J0DgAqwB5~LK}1^H!&O=l-E6?oizL;aivM1r1aCj%>aIt)z(JAy+} zEH?08@gBs!R)T)fpw>c$DA?8jY3$j=D~^LA503+d(rn_m=#omz!&If4!jgWV2#E92 z9Kh(&Cx-3ndq&vC(kja0r+}9zq2i@RwP|Ik+CMsC$0k02O_ND3cC^< z2+-=XGE`$==H<|VuQ?*rGs_4O_#$aUrxb$u2++8idGQ4c$54CcsRBe76)W?z=KV^| z^KEmuu7Pm}()!aXEM$Awom1HHv9p5&W zgQJT9QJa6DaPKvlqPNcjUV>aa{6LzL3=52|dyn$hZ$t0g4W@90d{$OJes{jDbllNB zA;MxtL2B050OwBSql`t|kf0%2@LI1rw!X<~En{Bo0OW@cS+civ`e%npc+ApCVY*n4 zF&&8G`c2<0Zmp!1;ah&r;H^KJHI7I12+`hear2~AIDUvX5f9JDEX*{#~;3&XUvuRrZY+v7%sZ{ z{a%h_MOX6p)1(>nDw(0{VA=aO_hZPTQoGLJ#s|J!)Xa#-$6{VR?-65_O~2r$>|^cb+}jm^!n3H7eRofhf?Lx66{M zCf&^RMj-7Q*r~TxI<88X{2f-S)d`l_Qx3w~65qC1{~`sIATUwCwdm3#L(fLf+EHp# zT+JS-(mFnVI**=o9MtlA9e7#_m_|yWQHr|pZ-RZJ-Vk%$(R}G^41tU$u`)_7;xGD+ zpOZbPu`{aC!H;B5T){Wz1R3$=0#d4A?jy~x5fOIDCevV<^v>R}FZQbQ(jNEqn(SI# zSp_R0s9_!h9s~H;0mR3SZq8gBtXV?6CD0@~2)V1YlEKOEzv9|Q8SI;Ym7)=N!)mi5 zRNxll7Q2UhNc&1btT@W^$Y)P84d2{f*;!db-6uAaw4BEAC|w!j{T2gJWo$(PPkT^C zLLe)wcoY?Ia)qo*l7O}RWllN?ZyrF;SS0?anA*c*|ByvDXRQ)8in$lT$_FQMBzGHG zrz|Ula}cF_)}bzw!%|JmK zCVg}ey`~fW8y#65=b?_Zb(|9`L-3Bzo92?uBYbtl7p>Khi$^AncEoON$m_T_!bDH*>~~awJGbiWbbJ%$Gp3sx6oqmKz(;D&%OEehiz{ zL;xjOz&3O&{!xFrYU82B?Qm7=%+CWpg+lkmm+bID1niJwjtQb^RFfpyV(!n~K`e%G z6^GCzKn|VHR6>d}aa(Ej*%(_Cd8_x%VU1wuNGZeRn7HmC@0g-!F1yxFi}ltBU7VEs6teb8GnkXSM(^> zRxgM!qWyqCLVtVLMIQe%Z*>e%*+7#wqK^x;f}Equ8-{bNUBF2oMDBCRcu<#T-S^WT z+8*wT<%u#)1Z&R4a7S#DL5eSVo7}r)o+tAHuLB0#pVRIB*d^o^c<-$)(k+ z*dSQVF4fO1J3I2?y1H?DFE`J2e>rXj93s%d(>DnPI%?{(ZykkqIPwnBzd%DR$~KTw zP@JECB}?__R&2J~e;HAsF0z*0WEj0dcG`I; zf|RO2K}#0L8uF!%diXm7#-!AnhtqDJTAvqntKeJeCB$9BTkqp|FL%?6Am1rVp?kT% zI6T=;%9=|RzO=#AH^e*-8Subpzb5ytg^~Gp!&NZ9HI`QI%s^>YBDf$_4zRbr!0${+ z%}Rz(&M!#DN(Z1mCl@ppG;YEgsN8WVL|WW@`ilE)3j|RjWQ>_qt0~qeRjDz>CR>;& zu3K9fBGQERqTL=N`pe=@Xg%%egYkj!d*V}H{SmUf=za2VJ2{nDn>c8MrpWcwRs0`Q ziR_Wu#O@MptO<=^itZ=GcR5EORn~&NAmzJPIwUiRrVb+(iI~f8R?C>TyC$sLrT323 ze>m16DZ^rR-7#TLV5HXqjnWds%=V$=z^cc=!^}#R+m-{NCoG-$u+zh~JR4tDaXuE4 zvBPSoLvFDzIh=r7q?3u0WT<;Ol#{lSa!fB*@3fBDb?!*uVVX~knqx6qRxcAottc71 zRnHlth3|AGa!Z8O@v`x>ViqEW_&U; zU@OK~J;ePecLEv!*aL1v{)>E+muEGXPx$}pr{aNnpKQp_`5A$N|BckLx~g0)twoIj z{0L@6P-er)d$I`PL<6W6r4dvSY4g~gz-bM-#ab)l({J*b8M1dP9C_q3T^uQ66@|X_ z8wv;xFjAwThZEA!jIMO9z*3?_z<#A3a6uKyOob0X8()E)We(GoLxoQ_3OG*a3-RgT zMG4v!8u=P3t1~zYuAZ;{itxT%52eH&ads0y=Uqhw(`V>!Y^STnRi^Q>IN)ONfN34X z{Bd0*ipW|d1ByjEf*#zFLJ`S|@Ci~llxqLr&yFpfEk=MqZsrN@4w1`B4v z7KSn*%_~p>X;1LA_jUui5mKT0Qpa2*VcM&rFEmGm){3gc17`=j_>dYD>;nP zBwMt^ZpY-8=R^=3i)6!MOhT{6sFNCt=cJiF+jPp$Q*Ss9HML3737D_39M6Vtp+?%x z-=*kd;`U;X@-BIFjAuf%VlV=gH&SgX?I=ycdyZf$te`wsczDvkwN<^8nDQW|sJC-lOgO_FPaCZSML}4A6>_Ot zvDaW60_Kg^R$Q|&|5juZi#wEoc2^7`%t-1`B_0LIe)dQ!u6SSy1_XV^QS(S?+Pcm1 zN|r-hMW4xd;UF(HtjNH6JvTHSFI4O`-FUj8%h-FQ_$`N_?6)+BN7_dp9uE*k{LZRS5gqWdC7{?~NppvNK-X575 zWk}Rz-?QRgPpmW9eIe6{dRI``;0r~-9F#6&F__;MdlLvuXa5v__+!`zJ$Bi{)*2V} zzWhqzo#Sr=SfWOO_0|+Km7VUkKmOI|`*gxqb*KBla$6^%^NlU4Gm&T@0YVfnt_0g` zUcaljO{0J@I2c1DDNcX5>q>JtB6ZK|MNWxkin(m+n|~zjQ)=ETf?$qEJKKJ*s?t;!PXLSnrZ^ zW>3YKVTHwa*-gmF%>I1bR=cW*+f$?v4&0v@8upDKCPS%dkO!cq>LAq?FgE}}SoOin zkriEE!9&aAJ|2o3HH)5>Q7kRT3)Mt;Rac#A@8ov|6EHU3w_DZgRdvlT98=tbg_lDK zM)G9JHw%7ja`>Gh@f)^I;#lsx%6#oxrFxbxa4VM8-xt;e_E=T~H>BIQV-c58&Qw$+ zj7vLCQx#4kmduDMs~Egbf7*U)W3y}tEI@WsHSl0e$J;Sv>|VC zf0?h1U(10=loX52R3@lpZ|<&m=9ae1K(#$C*LS?IhSURM}j%oA`24 zU2W%%n)YTbgt!;%^6zYhUWQr5 zPi=EJ`K2zj;EwvVJMB&TfDL7t9BueyQl5dR0mu}&saxBQIvxR!6a;}0P7=Sry#^AL zmJmMqcv1k_ck6)Kw%sfib_NljnbnHSpv030(V?eSzV1=f*!us#rSCveXh8~ zQ)2%Z_d3q?qR-xubkT}Y$Z>ckF9nvM6w1TWq~Iby!PR>T`PqdPF%EuvT-Q}FH*6(p zrhv>5ETKX)j7lOtB(LqQ`03U}hac}7ALJMW9c&m*OSo1Bxbi?Wk_cG!eUjPSky$5c zwU^1L4gG>iuX{dyBC{y^{LB=+kVS=MK&?}Sn1c+lJtYTnEqzPJ{j5? zb`hIv9nxWv)zk=cETPIivU|@o7`*(a(#_Oqn>1G=0SaxHI8yJP3^#}@$_?=`7wlu~ zhxD*WrM4+pFfx7;MSQq28PFg;t0nCOOQ>f*@VF(bscyV|vwdgkHeDQkwDtN9k&wfH zWl|V}Nf4qVd~mcOm%cHMe1ECu!LZRu+;}pyJ%;dN%k#MR8gHcB+}AT6kn+`@Q)i|8B{J!pO zbxi-JyTH?@m8yp-W2cN+GzTBw-(wWL_lEx4o0-oh^Vjo`q|xerFP+G&~&YZDrE@9Q*rvRKo?q_`jd`E(5cTvtwT z)hK)cHZVq@T#C%^hh>}x`~4Y72Yl-dKED6nIHJw7 zTPci4PEHn6Xk#vDQPWKw`f0CbL16fCpN_Q))H`)3@u2MTPo1wbSfHp{8~QW4$;+u( zu$3Vhu}t4u4Cet)6vmZ!RU`FKH-(P%?QB?eA(~_!2W)J|4zqTuxH)TwXMUYJZ44!P zG)*Gsp#q0+u#KnB_@MK4kp%6B$LTP=qyrVCv$(z$A9mSmqWI}w%P#W7jlm4&4HPpI zy98hh5P#K~6(SIgCY;5`N=I_cl6J3k+4m5L99UVKAy<5vC@wmBdn6U%Fhqy2ZP;a? zGNg|G-FKE_F!hIT)@zudEd?Haw_51LXOeejIX-1d3=$A&>-p%hPCF$L6ESx77L2bF zaiIF>OWP=%<7?g9+zM|x;EKL;v&MJ88Iyi<7aMp&-SZ-DE*hoa%mi}c$paMKw6rc9 zto_dxtr&>|ctzvj@f$W3_s0mT&Atvo7b~<*S0ZtbF;A=L_<>_o%seaD0ns@t2kvq{ zT#3cj0Ui)|!vDy?@Y``e=M4-rM)YUwkFv&(6H+&%PyBd80?Da9_Un4SJm$G-%_Wid ze3^OB&`-!vA{dJo*#r;kx2P%>Bqv_KT+&14{SevbP-pjwFV(LK$vhZ&fn|}|^NCN3 zNYiNRi@=a+nMyP!!Z5$8TZbKx*uHF^;d3Uza4BIW8vHt;K47T#CxFkgtS|`NdzsW% z;sJ%fHaUZ4z9}*Bbj!v+FQHO$X0j;$%{pc zH^qL`X%;R?GJsj!XKKjEs3VLj0`|kCW|QJjR}>UHIQs1m>-bg9eY34L1|Q?t>?G=> z>jM!eI$03213DoJC^c7i83i%K9%P{?K5X*hthFWkL`C!h!A%7tUIEq=@_WkRj_Gp# z8a-8Ri_>VaZ4p&d!(=p-{axA2++o3xJ(d9EaMLmIF364fW~N6r%MW)Ejzt#kYKfpE zEnB-!o@y;oZz#T0_JuMn9wJ#{mE|IsMLnLlXBJg6J;j8`gR^5IZ)sO9^up6WZ8Qu) zmh6!63Bj9QrjK(jwd58}(|u)Qan)OJhF}}@&akqOCE0-`mQ?pGi#F>*d>8J>jyXgc zX}hz!d&nP)w|mMo14agpcbyE`z!nIPYrDV<*4!LVFjU19o|>KFAzDczm(tlK`cHiH z#x+chsztX`Qt8=|_n?$H!*zUbq_cBVE<`mnzWG|KUABli}*?+5Nn90BWU%%1`})Mn;f2u)jCq{INs_{i^uq zRxaE@yyl)FsPXGE{GOZl21--?!;g4_`F=q;JFevWJ*NZ!e#mb(!H}DoId=2U!0V!!Iob zP?)Rv5u|oW$#?h*>{da3e;)3xf;3zbTNb9WvI(p z_s*gA|NlWEq5h>q z3@}dw@eSgDCKdqo$kl{mpa^onTLm{(FMlHZ6b1ri_@ixHNDuQ*mTxPhK zpaYZvmj1tDxVBwfO^g8wLjXLhzOhRAl_mq!8CUaMfZFfBY5NzlUVw7^Xc!k$27q!P zu-vd8E^u61F+YGVO0RkA%f7iN9Suq$!*heaxhmXz8RW8N^f}7M{}$xh3c4y8ea-_^ zG2*>R*Idv_zU-FE63yorzCd~68+)36Y9IWyH2zzcTvSCqX8|U!;r|b4uFi^n)XQas z<8uskf&UERT9^EgjJ&8=e9i&@U<>{SG(Yu=L0icWh>J48pb%6-{~5&Jy5yoPFDQ+e z@P9ya_YX<1%PzSn!3zp8^WQ;S>yqpAcF%d9i~I*JxmJDmvWG6J-kuWy0Kq^N(HrYp zE=a&$X1FXodrlD|_FpkvTS-^dU(ZnhfT;U74|BD1`@wKg!xfZ4>A`=+aIHhG3bBI1 z;EVrzn7@%_1#KEvwG2UxtH}Ig<3HteE}S3yl7_kP>i?u{2ugTW)DV>L%fBT&mpHs^ z?4l$gsIfP|bCrMiwElF*AI8oF3PCMirzUuAQyCa<`L8VgI-B_A{9mv9owgt-)eom% z)D}Ev0sub#TdKcR8U(d{otoacbrbo2>5)HUP=ER3&);c5U;m{_1j=(&Tko6(09gG^ zo@+EOu2VhxAC&e$S+CRBJEsj+_&wiU)e!i5R1g)nYrT3^aqpZH0H6UXYyYcu|7UGp zQrEi<^WsJ9YZkvWyd@bE|3V!EwwyMAB#q&s~zZ-~jE)}_!@~WQS zIU_Jhn%a#~g2rS0y*vL_-4FChx~l63%3Sd;m@i6e{NYeggI5KrKn-dG({KFKA?BjN zYld!6^VezkoCCbmzajG=11+fa>!eH0tqTHE(fsCzzc_w^n!c)Oac&p@NCoO;|E}qa zqavv7>(mR*t=}{IZQEA|I#BahZ-Ad02MT;x-jw-^BOEBf)oZ1o1PQjkO>ku}0=0hi zt{A9wF^8M64l=@k8ow^I{@i@H+ix2O89PAjUX8duw+g&6_xy(J{t|%&wS6@h7u2@0 e*A3bR9SUS6p@6pmfeE02-|W=DbVj~Ee*1rA5$4VS literal 0 HcmV?d00001 diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm index 4a7e3c32..8c778061 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm @@ -152,7 +152,8 @@ tcl::namespace::eval textblock { hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} } proc use_hash {args} { - set argd [punk::args::get_by_id ::textblock::use_hash $args] + #set argd [punk::args::get_by_id ::textblock::use_hash $args] + set argd [punk::args::parse $args withid ::textblock::use_hash] variable use_hash if {![dict exists $argd received hash_algorithm]} { return $use_hash @@ -4143,7 +4144,8 @@ tcl::namespace::eval textblock { proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + #set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] + set opts [dict get [punk::args::parse $args withid ::textblock::periodic] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -7913,7 +7915,8 @@ tcl::namespace::eval textblock { #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { #as frame is called a lot within table building - checking args can have a *big* impact on final performance. - set argd [punk::args::get_by_id ::textblock::frame $args] + #set argd [punk::args::get_by_id ::textblock::frame $args] + set argd [punk::args::parse $args withid ::textblock::frame] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8650,7 +8653,7 @@ tcl::namespace::eval textblock { size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id ::textblock::gcross $args] + set argd [punk::args::parse $args withid ::textblock::gcross] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.4.tm b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.4.tm index 33d5b912..c472eace 100644 --- a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.4.tm +++ b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.4.tm @@ -81,6 +81,15 @@ namespace eval tomlish { namespace export {[a-z]*}; # Convention: export all lowercase variable types + #default interp recursionlimit of 1000 is insufficient to pass 1000 deep nested structures as in certain toml tests. + #e.g https://github.com/iarna/toml-spec-tests/tree/latest/values + #1000 seems deep for a 'configuration' format - but toml sometimes used for other serialisation purposes. + #todo - review + set existing_recursionlimit [interp recursionlimit {}] + if {$existing_recursionlimit < 5000} { + interp recursionlimit {} 5000 + } + #IDEAS: # since get_toml produces tomlish with whitespace/comments intact: # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace @@ -102,6 +111,38 @@ namespace eval tomlish { # 4 = NEWLINE lf # 5 = NEWLINE lf + #This reordering idea is complicated by the nature of tablearrays - especially as a table header references last tablearrayname, + # and duplicate table headers are allowed in that context. + #e.g + #[[fruits]] + # name="apple" + # [fruits.metadata] + # id=1 + # + #[unrelated1] + # + #[[fruits]] + # name="pear" + # + #[unrelated2] + # silly="ordering" + # + #[fruits.metadata] + #id=2 + #The TABLEARRAY record can't be completely selfcontained on the default parsing mechanism - because it is legal (though not recommended) to have unrelated tables in between. + #If we were to 'insert' later related records (such as the 2nd [fruits.metadata] above) into the TABLEARRAY structure - then, even though it might produce 'nicer' toml, + # we would lose roundtripability toml->tomlish->toml + # ----------------------------------------------------- + #REVIEW + #todo - some sort of 'normalize'/'grouping' function on tomlish that at least makes records self-contained, and perhaps then (optionally) reorders resulting records sensibly. + #such a function on the tomlish may work - although it would be unwise to duplicate the validation aspects of to_dict + #The most practical way might be to use to_dict followed by from_dict - but that would lose comment info and formatting. + #In the above example - The decision by the toml author to put [unrelated1] between related tablearrays should be respected, + #but the positioning of [unrelated2] between a tablearray and one of its contained tables is suspect. + #Both [fruits.metadata] table records should theoretically be added as children to their corresponding [[fruits]] tablearray record in the tomlish. (just as their name keys are) + # ----------------------------------------------------- + + #ARRAY is analogous to a Tcl list #TABLE is analogous to a Tcl dict @@ -118,6 +159,7 @@ namespace eval tomlish { #removed - ANONTABLE #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + #todo - configurable - allow empty string for 'unlimited' set min_int -9223372036854775808 ;#-2^63 set max_int +9223372036854775807 ;#2^63-1 @@ -299,21 +341,22 @@ namespace eval tomlish { #(update - only Creating and Defining are relevant terminology) #review - #tablenames_info keys created, defined, createdby, definedby, closedby + #tablenames_info keys type created, defined, createdby, definedby, closedby ??? review keys + # [tname] = header_table [[tname]] = header_tablearray #consider the following 2 which are legal: - #[table] #'table' created, defined=open definedby={header table} + #[table] #'table' created, defined=open type header_table #x.y = 3 - #[table.x.z] #'table' defined=closed closedby={header table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header table.x.z} + #[table.x.z] #'table' defined=closed closedby={header_table table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header_table table.x.z} #k= 22 # #'table.x.z' defined=closed closedby={eof eof} #equivalent datastructure - #[table] #'table' created, defined=open definedby={header table} - #[table.x] #'table' defined=closed closedby={header table.x}, 'table.x' created defined=open definedby={header table.x} + #[table] #'table' created, defined=open definedby={header_table table} + #[table.x] #'table' defined=closed closedby={header_table table.x}, 'table.x' created defined=open definedby={header_table table.x} #y = 3 - #[table.x.z] #'table.x' defined=closed closedby={header table.x.z}, 'table.x.z' created defined=open definedby={header table.x.z} + #[table.x.z] #'table.x' defined=closed closedby={header_table table.x.z}, 'table.x.z' created defined=open definedby={header_table table.x.z} #k=22 #illegal @@ -439,14 +482,285 @@ namespace eval tomlish { } TABLEARRAY { - set tablename [lindex $item 1] - log::debug "---> to_dict processing item TABLENAME (name: $tablename): $item" - set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + + set NEST_DICT [dict create] ;#first blush attempt at referencing supertable tablearrays + set tablearrayname [lindex $item 1] + log::debug "---> to_dict processing item TABLENAME (name: $tablearrayname): $item" + set norm_segments [::tomlish::utils::tablename_split $tablearrayname true] ;#true to normalize #we expect repeated tablearray entries - each adding a sub-object to the value, which is an array/list. + #tablearrayname is likely to appear multiple times - so unlike a TABLE we don't check for 'defined' for the full name as an indicator of a problem + set supertable [list] + ############## + # [[a.b.c.d]] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of tablearray name $tablearrayname already has data but doesn't appear to be a table - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_supertable_keycollision + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } else { + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #REVIEW!! + # what happens with from_toml {[[a.b.c]]} {[[a]]} ??? + dictn set tablenames_info [list $supertable type] header_table ;#how do we know it's not going to be a tablearray? + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } else { + #supertable has already been created - and maybe defined - but even if defined we can add subtables unless it is of type itable + #but if it's a tablearray - we need to point to the most 'recently defined table element of the array' + #(another way of saying last member of that array)?? + set supertype [dictn get $tablenames_info [list $supertable type]] + if {$supertype eq "header_tablearray"} { + puts stdout "todict!!! TABLEARRAY nesting required for supertable [join $supertable .]" + puts stdout "todict!!! todo.." + #how to do multilevel nesting?? + set EXISTING_SUPERARRAY_ELEMENTS [dict get $datastructure {*}$supertable value] + dict set NEST_DICT $supertable $EXISTING_SUPERARRAY_ELEMENTS + puts stdout "todict!!! supertable '[join $supertable .]' elements $EXISTING_SUPERARRAY_ELEMENTS" + } + } + } + # + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + #first encounter of this tablearrayname + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[[a]]} + set msg "Cannot create tablearray name $tablearrayname. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_direct_keycollision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no collision - we can create the tablearray and the array in the datastructure + dictn set tablenames_info [list $norm_segments type] header_tablearray + dict set datastructure {*}$norm_segments [list type ARRAY value {}] + set ARRAY_ELEMENTS [list] + } else { + #we have a table - but is it a tablearray? + set ttype [dictn get $tablenames_info [list $norm_segments type]] + #use a tabletype_unknown type for previous 'created' only tables? + if {$ttype ne "header_tablearray"} { + set msg "tablearray name $tablearrayname already appears to be already created as a table not a tablearray - invalid?" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #add to array + #error "add_to_array not implemented" + #{type ARRAY value } + set ARRAY_ELEMENTS [dict get $datastructure {*}$norm_segments value] + } + + + set object [dict create] ;#array context equivalent of 'datastructure' + set objectnames_info [dict create] ;#array contex equivalent of tablenames_info + + #add to ARRAY_ELEMENTS and write back in to datastructure. + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #MAINTENANCE: temp copy from TABLE + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [_get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + #set supertable $norm_segments + set supertable [list] ;#disconnect from main structure - each array element is a new context for key paths! + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey '$dottedkeyname' kv: $keyval_dict" + #dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #wrong + #TODO!!!!!!!!!!!!! + #lappend ARRAY_ELEMENTS [list $dottedkeyname $keyval_dict] + dict set object $dottedkeyname $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + TABLE { + #we should be able to process tablearray subtables either as part of the tablearray record, or independently. + #(or even a mixture of both, although that is somewhat an edge case) + #[[fruit]] + #x=1 + # [fruit.metadata] + # [fruit.otherdata] + + #when processing a dict destined for the above - the tomlish generator (e.g from_dict) + #should create as 1 or 3 records (but could create 2 records if there was an unrelated table in between the subtables) + #choices: all in tablearray record, tablearray + 1 or 2 table records. + # + #We are going the other way here - so we just need to realize the list of tables 'belonging' to this tablearray might not be complete. + # + #the subtable names must be prefixed with the tablearray - we should validate that for any contained TABLE records + + } + default { + error "Sub element of type '$type' not understood in tablearray context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + #todo? + ##end of TABLE record - equivalent of EOF or next header - close off the dottedtables + #foreach dtablepath $dottedtables_defined { + # dictn set tablename_info [list $dtablepath defined] closed + #} + + if {[dict size $NEST_DICT]} { + puts "reintegrate?? $NEST_DICT" + #todo - more - what if multiple in hierarchy? + dict for {superpath existing_elements} $NEST_DICT { + #objects stored directly as dicts in ARRAY value + set lastd [lindex $existing_elements end] + #insufficient.. + #dict set lastd [lindex $norm_segments end] [list type ITABLE value $object] + dict set lastd [lindex $norm_segments end] $object + #set lastd [dict merge $lastd $object] + lset existing_elements end $lastd + dict set datastructure {*}$superpath [list type ARRAY value $existing_elements] + } + } else { + #lappend ARRAY_ELEMENTS [list type ITABLE value $object] + lappend ARRAY_ELEMENTS $object + dict set datastructure {*}$norm_segments [list type ARRAY value $ARRAY_ELEMENTS] + } } TABLE { set tablename [lindex $item 1] + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + #As our TABLE record contains all it's child DOTTEDKEY records - this should be equivalent to setting them as defined at EOF or next header. + log::debug "---> to_dict processing item TABLE (name: $tablename): $item" #set tablename [::tomlish::utils::tablename_trim $tablename] set norm_segments [::tomlish::utils::tablename_split $tablename true] ;#true to normalize @@ -456,7 +770,8 @@ namespace eval tomlish { #our tablename e.g [a.b.c.d] declares a space to 'define' subkeys - but there has already been a definition space for this path set msg "Table name $tablename has already been directly defined in the toml data. Invalid" append msg \n [tomlish::dict::_show_tablenames $tablenames_info] - error $msg + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg } @@ -476,29 +791,33 @@ namespace eval tomlish { #supertable with this path doesn't yet exist if {[dict exists $datastructure {*}$supertable]} { #There is data though - so it must have been created as a keyval - set msg "Supertable [join $supertable .] of table name $tablename already has data - invalid" + set msg "Supertable [join $supertable .] of table name $tablename already has data but doesn't appear to be a table (keycollision) - invalid" append msg \n [tomlish::dict::_show_tablenames $tablenames_info] - error $msg - } else { - #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here - dictn set tablenames_info [list $supertable type] header - #ensure empty tables are still represented in the datastructure - dict set datastructure {*}$supertable [list] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] header_table + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] } else { - #supertable has already been created - and maybe defined - but even if defined we can add subtables + #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable + } } #table [a.b.c.d] hasn't been defined - but may have been 'created' already by a longer tablename # - or may have existing data from a keyval if {![dictn exists $tablenames_info [list $norm_segments type]]} { if {[dict exists $datastructure {*}$norm_segments]} { - set msg "Table name $tablename already has data - invalid" + #e.g from_toml {a=1} {[a]} + set msg "Cannot create table name $tablename. Key already has data but key doesn't appear to be a table (keycollision) - invalid" append msg \n [tomlish::dict::_show_tablenames $tablenames_info] - error $msg + #raise a specific type of error for tests to check + #test: datastructure_tablename_keyval_collision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg } #no data or previously created table - dictn set tablenames_info [list $norm_segments type] header + dictn set tablenames_info [list $norm_segments type] header_table #We are 'defining' this table's keys and values here (even if empty) dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here @@ -512,47 +831,131 @@ namespace eval tomlish { log::debug "----> todict processing $tag subitem $type processing contained element $element" switch -exact -- $type { DOTTEDKEY { + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? set dkey_info [_get_dottedkey_info $element] #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) - set dotted_key_hierarchy [dict get $dkey_info keys] - set dkeys [lrange $dotted_key_hierarchy 0 end-1] - set leaf_key [lindex $dotted_key_hierarchy end] - #ensure empty keys are still represented in the datastructure - set test_keys $norm_segments - foreach k $dkeys { - lappend test_keys $k - if {![dict exists $datastructure {*}$test_keys]} { - dict set datastructure {*}$test_keys [list] + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + set supertable $norm_segments + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # } else { - tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } } } + #assert - dottedkey represents a key val pair that can be added + - if {[dict exists $datastructure {*}$norm_segments {*}$dkeys $leaf_key]} { - error "Duplicate key '$norm_segments $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg } + set keyval_dict [_get_keyval_value $element] #keyval_dict is either a {type value } #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level #punk::dict::is_tomlish_typeval can distinguish - puts stdout "to_dict>>> $keyval_dict" - dict set datastructure {*}$norm_segments {*}$dkeys $leaf_key $keyval_dict - #JMN 2025 - #lappend tablenames_info [list {*}$norm_segments {*}$dkeys] - set tkey [list {*}$norm_segments {*}$dkeys] - dictn incr tablenames_info [list $tkey seencount] + puts stdout "to_dict>>> TABLE/dottedkey $dottedkeyname kv: $keyval_dict" + dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #remove ? if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys # inner structure will contain {type value } if all leaves are not empty ITABLES - set tkey [list {*}$norm_segments {*}$dkeys $leaf_key] + set tkey [list {*}$norm_segments {*}$all_dotted_keys] #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] - dictn incr tablenames_info [list $tkey seencount] - #if the keyval_dict is not a simple type x value y - then it's an inline table ? - #if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. - dictn set tablenames_info [list $tkey closed] 1 + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 } } @@ -564,6 +967,14 @@ namespace eval tomlish { } } } + + #end of TABLE record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dictn set tablename_info [list $dtablepath defined] closed + } + + + #review??? #now make sure we add an empty value if there were no contained elements! #!todo. } @@ -889,24 +1300,74 @@ namespace eval tomlish { } } - proc _from_dictval {parents tablestack keys vinfo} { - set k [lindex $keys end] - if {[regexp {\s} $k] || [string first . $k] >= 0} {} - if {![::tomlish::utils::is_barekey $k]} { - #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + #take a raw string and classify: result is a 2 element list comprised of KEY|SQKEY|DQKEY and the value being the appropriate inner string + proc _from_dict_classify_key {rawval} { + if {![::tomlish::utils::is_barekey $rawval]} { #requires quoting - #we'll use a basic mechanism for now to determine the type of quoting - whether it has any single quotes or not. + # + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + # + #we'll use a basic mechanisms for now to determine the type of quoting + # - whether it has any single quotes or not. + # (can't go in an SQKEY) + # - whether it has any chars that require quoting when in a Bstring + # (if so - then its visual representation might be unsuitable for a key in a toml text file, so escape and put in DQKEY instead of literal SQKEY) #todo - more? + #REVIEW - the backslash might often be in things like a regex or windows path - which is often better expressed in a literal SQKEY + # from literal examples: + # 'c:\Users\nodejs\templates' + # '<\i\c*\s*>' + #If these are in *keys* our basic test will express these as: + # "c:\\Users\\nodejs\\templates" + # "<\\i\\c*\\s*>" + # This still works - but a smarter test might determine when SQKEY is the better form? + #when coming from external systems - can we even know if the value was already escaped? REVIEW + #Probably when coming from json - we know it's already escaped - and so we build our dict converting keys to unescaped + #TODO - clarify in documentation that keys resulting from to_dict are in 'normalized' (unescaped) form + # #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) - if {[string first ' $k] >=0} { + set k_escaped [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + if {[string length $k_escaped] != [string length $rawval]} { + #escaping made a difference + set has_escape_requirement 1 + } else { + set has_escape_requirement 0 + } + if {[string first ' $rawval] >=0 || $has_escape_requirement} { #basic string + # (any ANSI SGR sequence will end up here in escaped form ) + return [list DQKEY $k_escaped] } else { #literal string - set K_PART [list SQKEY $k] + return [list SQKEY $rawval] } } else { - set K_PART [list KEY $k] + return [list KEY $rawval] + } + } + + #the quoting implies the necessary escaping for DQKEYs + proc _from_dict_join_and_quote_raw_keys {rawkeylist} { + set result "" + foreach rk $rawkeylist { + lassign [_from_dict_classify_key $rk] type val + switch -- $type { + SQKEY { + append result "'$val'." + } + DQKEY { + append result "\"$val\"." + } + KEY { + append result "$val." + } + } } + return [string range $result 0 end-1] + } + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + set K_PART [_from_dict_classify_key $k] ;#get [list SQKEY ] puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" puts stderr "---tablestack: $tablestack---" set result [list] @@ -918,7 +1379,6 @@ namespace eval tomlish { set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} } else { - #set result [list TABLE $k {NEWLINE lf}] if {$vinfo ne ""} { #set result [list DOTTEDKEY [list [list KEY $k]] = ] @@ -930,8 +1390,8 @@ namespace eval tomlish { set result [list DOTTEDKEY [list $K_PART] =] set records [list ITABLE] } else { - #review - quoted k ?? - set result [list TABLE $k {NEWLINE lf}] + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + set result [list TABLE $tname {NEWLINE lf}] set tablestack [list {*}$tablestack [list T $k]] set records [list] } @@ -941,13 +1401,17 @@ namespace eval tomlish { set lastidx [expr {[dict size $vinfo] -1}] set dictidx 0 dict for {vk vv} $vinfo { - if {[regexp {\s} $vk] || [string first . $vk] >= 0} { - set VK_PART [list SQKEY $vk] - } else { - set VK_PART [list KEY $vk] - } + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + #(SQKEY & DQKEY do not have the enclosing quotes in their returned val) + #if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + # set VK_PART [list SQKEY $vk] + #} else { + # set VK_PART [list KEY $vk] + #} if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y + #REVIEW - we could detect if value is an array of objects, + #and depending on parent context - emit a series of TABLEARRAY records instead of a DOTTEDKEY record containing an ARRAY of objects set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] } else { @@ -956,8 +1420,11 @@ namespace eval tomlish { if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] - set tname [join [list {*}$keys $vk] .] - set record [list TABLE $tname {NEWLINE lf}] + + #we can't just join normalized keys - need keys with appropriate quotes and escapes + #set tname [join [list {*}$keys $vk] .] ;#WRONG + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] set tablestack [list {*}$tablestack [list T $vk]] } else { set record [list DOTTEDKEY [list $VK_PART] = ITABLE] @@ -968,8 +1435,8 @@ namespace eval tomlish { #experiment.. sort of getting there. if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" - set tname [join [list {*}$keys $vk] .] - set record [list TABLE $tname {NEWLINE lf}] + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] set tablestack [list {*}$tablestack [list T $vk]] #review - todo? @@ -1004,9 +1471,10 @@ namespace eval tomlish { } } else { if {$lastparent eq "do_inline"} { - lappend result DOTTEDKEY [list [list KEY $k]] = ITABLE {NEWLINE lf} + lappend result DOTTEDKEY [list $K_PART] = ITABLE {NEWLINE lf} } else { - lappend result TABLE $k {NEWLINE lf} + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + lappend result TABLE $tname {NEWLINE lf} } } } @@ -1020,8 +1488,9 @@ namespace eval tomlish { if {$lastparent eq "TABLE"} { #review dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] - lappend result [list DOTTEDKEY [list [list KEY $vk]] = $dottedkey_value {NEWLINE lf}] + lappend result [list DOTTEDKEY [list $VK_PART] = $dottedkey_value {NEWLINE lf}] } } else { if {$vinfo ne ""} { @@ -1033,11 +1502,7 @@ namespace eval tomlish { set result ITABLE set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] dict for {vk vv} $vinfo { - if {[regexp {\s} $vk] || [string first . $vk] >=0} { - set VK_PART [list SQKEY $vk] - } else { - set VK_PART [list KEY $vk] - } + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] if {[tomlish::dict::is_tomlish_typeval $vv]} { #type x value y set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] @@ -1049,7 +1514,7 @@ namespace eval tomlish { # (including what's been inlined already) #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { # puts stderr "_from_dictval uninline2 KEY $keys" - # set tname [join [list {*}$keys $vk] .] + # set tname [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] # set record [list TABLE $tname {NEWLINE lf}] # set tablestack [list {*}$tablestack [list T $vk]] #} else { @@ -1141,6 +1606,11 @@ namespace eval tomlish { set parents [list ""] } set keys [list $t] + #review - where to make decision on + # DOTTEDKEY containing array of objs + #vs + # list of TABLEARRAY records + #At least for the top set trecord [_from_dictval $parents $tablestack $keys $tinfo] lappend tomlish $trecord incr dictposn @@ -1180,6 +1650,7 @@ namespace eval tomlish { proc get_json {tomlish} { package require fish::json set d [::tomlish::to_dict $tomlish] + #return [::tomlish::dict_to_json $d] return [fish::json::from "struct" $d] } @@ -1970,10 +2441,6 @@ namespace eval tomlish::decode { #todo - check not something already waiting? tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space } - XXXdquotedkey { - #todo - set v($nest) [list DQKEY $tok] ;#$tok is the keyname - } barekey { switch -exact -- $prevstate { table-space - itable-space { @@ -2165,17 +2632,31 @@ namespace eval tomlish::decode { untyped_value { #would be better termed unclassified_value #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + unset -nocomplain tag if {$tok in {true false}} { set tag BOOL - } elseif {[::tomlish::utils::is_int $tok]} { - set tag INT - } elseif {[::tomlish::utils::is_float $tok]} { - set tag FLOAT - } elseif {[::tomlish::utils::is_datetime $tok]} { - set tag DATETIME } else { - error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + if {[::tomlish::utils::is_int $tok]} { + set tag INT + } else { + if {[string is integer -strict $tok]} { + #didn't qualify as a toml int - but still an int + #probably means is_int is limiting size and not accepting bigints (configurable?) + #or it didn't qualify due to more than 1 leading zero + #or other integer format issue such as repeated underscores + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. (looks close to being an int. Formatting or range issue?) [tomlish::parse::report_line] (no space level change)" + } else { + if {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok]} { + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + } + } } + #assert either tag is set, or we errored out. lappend v($nest) [list $tag $tok] } @@ -2567,7 +3048,7 @@ namespace eval tomlish::utils { dict set Bstring_control_map \n {\n} dict set Bstring_control_map \r {\r} dict set Bstring_control_map \" {\"} - #dict set Bstring_control_map \x1b {\e} ;#should presumably be only be a convenience for decode - going the other way we get \u001B + dict set Bstring_control_map \x1b {\e} ;#In spec it's included in the list of 'must be escaped', as well as the 'convenience' escapes - so we make it go both ways. dict set Bstring_control_map \\ "\\\\" #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ @@ -2951,14 +3432,18 @@ namespace eval tomlish::utils { if {![tcl::string::is integer -strict $numeric_value]} { return 0 } + + + #!todo - check bounds only based on some config value - #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements. + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements by default (for now) #presumably very large numbers would have to be supplied in a toml file as strings. #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max - if {$numeric_value > $::tomlish::max_int} { + #some question around implementations allowed to use lower values such as 2^31 on some systems? + if {$::tomlish::max_int ne "" && $numeric_value > $::tomlish::max_int} { return 0 } - if {$numeric_value < $::tomlish::min_int} { + if {$::tomlish::min_int ne "" && $numeric_value < $::tomlish::min_int} { return 0 } } else { @@ -3076,8 +3561,52 @@ namespace eval tomlish::utils { } } - #review - we + proc is_datepart {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + + return 1 + } + proc is_localdate {str} { + is_datepart $str + } + proc is_timepart {str} { + set numchars [tcl::string::length $str] + #timepart can have negative or positive offsets so - and + must be accepted + if {[regexp -all {[zZt0-9\-\+\.:]} $str] == $numchars} { + #todo + return 1 + } else { + return 0 + } + } + proc is_localtime {str} { + #time of day without any relation to a specific day or any offset or timezone + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\.:]} $str] == $numchars} { + #todo + return 1 + } else { + return 0 + } + } + + #review proc is_datetime {str} { + #Essentially RFC3339 formatted date-time - but: + #1) allowing seconds to be omitted (:00 assumed) + #2) T may be replaced with a single space character TODO - parser support for space in datetime! + # (RFC 3339 allows space instead of T also - but doesn't specify it *must* be a single space) + + #toml-lint @2025-04 doesn't accept t for T or z for Z - but RFC3339 does + #toml spec doesn't clarify - we will accept + #e.g 1979-05-27 #e.g 1979-05-27T00:32:00Z #e.g 1979-05-27 00:32:00-07:00 @@ -3086,20 +3615,53 @@ namespace eval tomlish::utils { #review #minimal datetimes? - # 2024 ok - shortest valid 4 digit year? + # 2024 not ok - 2024T not accepted by tomlint why? # 02:00 ok - # 05-17 ok - if {[string length $str] < 4} { + # 02:00:00.5 ok + # 1:00 - not ok - RFC3339 requires 2-digit hr,min,sec + + #toml-lint.com accepts 2025-01 + + if {[string length $str] < 5} { return 0 } - set matches [regexp -all {[zZtT0-9\-\+\.:]} $str] + set matches [regexp -all {[zZtT0-9\ \-\+\.:]} $str] if {[tcl::string::length $str] == $matches} { #all characters in legal range + if {[regexp -all {\ } $str] > 1} { + #only a single space is allowed. + return 0 + } + #If we get a space - it is only valid as a convience to represent the T separator + #we can normalize by converting to T here before more tests + set str [string map {" " T t T} $str] + #a further sanity check on T + if {[regexp -all {T} $str] > 1} { + return 0 + } + #!todo - use full RFC 3339 parser? - lassign [split $str T] datepart timepart #!todo - what if the value is 'time only'? + if {[string first T $str] > -1} { + lassign [split $str T] datepart timepart + if {![is_datepart $datepart]} { + return 0 + } + if {![is_timepart $timepart]} { + return 0 + } + } else { + #either a datepart or a localtime + #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day + # without any relation to a specific day or any offset or timezone." + if {!([is_datepart $str] || [is_localtime $str])} { + return 0 + } + } + + #Tcl's free-form clock scan (no -format option) is deprecated # #if {[catch {clock scan $datepart} err]} { @@ -3107,7 +3669,6 @@ namespace eval tomlish::utils { # return 0 #} - #!todo - verify time part is reasonable } else { return 0 } @@ -3814,9 +4375,7 @@ namespace eval tomlish::parse { #set next [list PUSHSPACE [lindex $transition_to 1]] set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 - #::tomlish::log::notice "goNextState REENTRANCY. calling goNextState $nexttokentype $tokentype" - #set result [::tomlish::parse::goNextState $nexttokentype $tokentype] - ::tomlish::log::debug "--->> zeropoppushspace goNextState REENTRANCY. calling goNextState $nexttokentype $currentstate" + ::tomlish::log::debug "--->> zeropoppushspace goNextState RECURSE. calling goNextState $nexttokentype $currentstate" set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] set result [dict get $transition_info newstate] } @@ -6040,14 +6599,22 @@ namespace eval tomlish::dict { } } -tcl::namespace::eval tomlish::app { - variable applist [list encoder decoder test] +tcl::namespace::eval tomlish::app { #*** !doctools #[subsection {Namespace tomlish::app}] #[para] #[list_begin definitions] + tcl::namespace::eval argdoc { + proc test_suites {} { + if {[package provide test::tomlish] eq ""} { + return [list] + } + return [test::tomlish::SUITES] + } + } + proc decoder {args} { #*** !doctools #[call app::[fun decoder] [arg args]] @@ -6101,14 +6668,28 @@ tcl::namespace::eval tomlish::app { exit 0 } + package require punk::args + punk::args::define { + @dynamic + @id -id ::tomlish::app::test + @cmd -name tomlish::app::test + @leaders + @opts -any 1 + -suite -default tests -choices {${[::tomlish::app::argdoc::test_suites]}} + @values -min 0 -max 0 + } proc test {args} { - set opts [dict merge [dict create] $args] - package require test::tomlish - if {[dict exists $opts -suite]} { - test::tomlish::suite [dict get $opts -suite] - } - test::tomlish::run + set argd [punk::args::parse $args withid ::tomlish::app::test] + set opts [dict get $argd opts] + set opt_suite [dict get $opts -suite] + test::tomlish::SUITE $opt_suite + #if {[catch {test::tomlish::SUITE $opt_suite} errM]} { + # puts stderr "Unknown test suite '$opt_suite'. Available suites: [test::tomlish::SUITES]" + # exit 1 + #} + set run_opts [dict remove $opts -suite] + test::tomlish::RUN } @@ -6150,40 +6731,61 @@ namespace eval tomlish::lib { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -if {$argc > 0} { - puts stderr "argc: $argc args: $argv" - - if {($argc == 1)} { - if {[tcl::string::tolower $argv] in {help -help h -h}} { - puts stdout "Usage: -app where appname one of:[tomlish::appnames]" - exit 0 - } else { - puts stderr "Argument '$argv' not understood. Try -help" - exit 1 - } +if {[info exists ::argc] && $::argc > 0} { + puts stderr "argc: $::argc args: $::argv" + set arglist $::argv + # -------------- + #make sure any dependant packages that are sourced don't get any commandline args + set ::argv {} + set ::argc 0 + # -------------- + package require punk::args + punk::args::define { + @dynamic + @id -id tomlish::cmdline + @cmd -name tomlish -help\ + "toml encoder/decoder written in Tcl" + @opts -any 1 + -help -type none -help\ + "display usage" + -app -choices {${[tomlish::appnames]}} } - set opts [dict create] - set opts [dict merge $opts $argv] - - set opts_understood [list -app ] - if {"-app" in [dict keys $opts]} { - #Don't vet the remaining opts - as they are interpreted by each app - } else { - foreach key [dict keys $opts] { - if {$key ni $opts_understood} { - puts stderr "Option '$key' not understood" - exit 1 - } - } - } - if {[dict exists $opts -app]} { - set app [dict get $opts -app] - if {$app ni [tomlish::appnames]} { - puts stderr "app '[dict get $opts -app]' not found" - exit 1 - } - tomlish::app::$app {*}$opts + set argd [punk::args::parse $arglist withid tomlish::cmdline] + lassign [dict values $argd] leaders opts values received + if {[dict exists $received -help] || ![dict exists $received -app]} { + #puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + puts stderr [punk::args::usage tomlish::cmdline] + exit 0 } + + set app [dict get $opts -app] + set appnames [tomlish::appnames] + set app_opts [dict remove $opts -app] + tomlish::app::$app {*}$app_opts + + #set opts [dict create] + #set opts [dict merge $opts $::argv] + + #set opts_understood [list -app ] + #if {"-app" in [dict keys $opts]} { + # #Don't vet the remaining opts - as they are interpreted by each app + #} else { + # foreach key [dict keys $opts] { + # if {$key ni $opts_understood} { + # puts stderr "Option '$key' not understood" + # exit 1 + # } + # } + #} + #if {[dict exists $opts -app]} { + # set app [dict get $opts -app] + # set appnames [tomlish::appnames] + # if {$app ni $appnames} { + # puts stderr "app '[dict get $opts -app]' not found. Available apps: $appnames" + # exit 1 + # } + # tomlish::app::$app {*}$opts + #} } ## Ready diff --git a/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.5.tm b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.5.tm new file mode 100644 index 00000000..7ff93c3e --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/tomlish-1.1.5.tm @@ -0,0 +1,6973 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# 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 tomlish 1.1.5 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin tomlish_module_tomlish 0 1.1.5] +#[copyright "2024"] +#[titledesc {tomlish toml parser}] [comment {-- Name section and table of contents description --}] +#[moddesc {tomlish}] [comment {-- Description at end of page heading --}] +#[require tomlish] +#[keywords module parsing toml configuration] +#[description] +#[para] tomlish is an intermediate representation of toml data in a tree structure (tagged lists representing type information) +#[para] The design goals are for tomlish to be whitespace and comment preserving ie byte-for byte preservation during roundtrips from toml to tomlish and back to toml +#[para] The tomlish representation can then be converted to a Tcl dict structure or to other formats such as json, +#[para] although these other formats are generally unlikely to retain whitespace or comments +#[para] The other formats also won't preserve roundtripability e.g \t and a literal tab coming from a toml file will be indistinguishable. +#[para] A further goal is to allow at least a useful subset of in-place editing operations which also preserve whitespace and comments. +#[para] e.g leaf key value editing, and table reordering/sorting, key-renaming at any level, key insertions/deletions +#[para] The API for editing (tomldoc object?) may require explicit setting of type if accessing an existing key +#[para] e.g setting a key that already exists and is a different type (especially if nested structure such as a table or array) +#[para] will need a -type option (-force ?) to force overriding with another type such as an int. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of tomlish +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by tomlish +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::stack +package require logger + +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {struct::stack}] + +#limit ourselves to clear, destroy, peek, pop, push, rotate, or size (e.g v 1.3 does not implement 'get') + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish { + namespace export {[a-z]*}; # Convention: export all lowercase + variable types + + #default interp recursionlimit of 1000 is insufficient to pass 1000 deep nested structures as in certain toml tests. + #e.g https://github.com/iarna/toml-spec-tests/tree/latest/values + #1000 seems deep for a 'configuration' format - but toml sometimes used for other serialisation purposes. + #todo - review + set existing_recursionlimit [interp recursionlimit {}] + if {$existing_recursionlimit < 5000} { + interp recursionlimit {} 5000 + } + + #IDEAS: + # since get_toml produces tomlish with whitespace/comments intact: + # tomldoc object - allow (at least basic?) editing of toml whilst preserving comments & whitespace + # - setKey (set leaf only to value) how to specify type? -type option? - whole array vs index into arrays and further nested objects? - option for raw toml additions? + # - separate addKey?? + # - deleteKey (delete leaf) + # - deleteTable (delete table - if only has leaves? - option to delete with child tables?) + # - set/add Table? - position in doc based on existing tables/subtables? + + #The tomlish intermediate representation allows things such as sorting the toml document by table name or other re-ordering of tables - + # because the tables include subkeys, comments and newlines within their structure - those elements all come along with it nicely during reordering. + #The same goes for the first newline following a keyval e.g x=1 \ny=2\n\n + #The newline is part of the keyval structure so makes reordering easier + #example from_toml "a=1\nb=2\n\n\n" + # 0 = TOMLISH + # 1 = KEY a = {INT 1} {NEWLINE lf} + # 2 = NEWLINE lf + # 3 = KEY b = {INT 2} {NEWLINE lf} + # 4 = NEWLINE lf + # 5 = NEWLINE lf + + #This reordering idea is complicated by the nature of tablearrays - especially as a table header references last tablearrayname, + # and duplicate table headers are allowed in that context. + #e.g + #[[fruits]] + # name="apple" + # [fruits.metadata] + # id=1 + # + #[unrelated1] + # + #[[fruits]] + # name="pear" + # + #[unrelated2] + # silly="ordering" + # + #[fruits.metadata] + #id=2 + #The TABLEARRAY record can't be completely selfcontained on the default parsing mechanism - because it is legal (though not recommended) to have unrelated tables in between. + #If we were to 'insert' later related records (such as the 2nd [fruits.metadata] above) into the TABLEARRAY structure - then, even though it might produce 'nicer' toml, + # we would lose roundtripability toml->tomlish->toml + # ----------------------------------------------------- + #REVIEW + #todo - some sort of 'normalize'/'grouping' function on tomlish that at least makes records self-contained, and perhaps then (optionally) reorders resulting records sensibly. + #such a function on the tomlish may work - although it would be unwise to duplicate the validation aspects of to_dict + #The most practical way might be to use to_dict followed by from_dict - but that would lose comment info and formatting. + #In the above example - The decision by the toml author to put [unrelated1] between related tablearrays should be respected, + #but the positioning of [unrelated2] between a tablearray and one of its contained tables is suspect. + #Both [fruits.metadata] table records should theoretically be added as children to their corresponding [[fruits]] tablearray record in the tomlish. (just as their name keys are) + # ----------------------------------------------------- + + + + #ARRAY is analogous to a Tcl list + #TABLE is analogous to a Tcl dict + #WS = inline whitespace + #KEY = bare key and value + #DQKEY = double quoted key and value + #SQKEY = single quoted key and value + #ITABLE = inline table (*can* be anonymous table) + # inline table values immediately create a table with the opening brace + # inline tables are fully defined between their braces, as are dotted-key subtables defined within + # No additional subtables or arrays of tables may be defined within an inline table after the ending brace - they must be entirely self-contained + + set tags [list TOMLISH ARRAY TABLE ITABLE TABLEARRAY WS NEWLINE COMMENT DOTTEDKEY KEY DQKEY SQKEY STRING STRINGPART MULTISTRING LITERAL LITERALPART MULTILITERAL INT FLOAT BOOL DATETIME] + #removed - ANONTABLE + #tomlish v1.0 should accept arbitrary 64-bit signed ints (from -2^63 to 2^63-1) + #we will restrict to this range for compatibility for now - although Tcl can handle larger (arbitrarily so?) + #todo - configurable - allow empty string for 'unlimited' + set min_int -9223372036854775808 ;#-2^63 + set max_int +9223372036854775807 ;#2^63-1 + + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] tomlish '$txt'" + puts stderr $msg + } + logger::initNamespace ::tomlish + foreach lvl [logger::levels] { + interp alias {} tomlish_log_$lvl {} ::tomlish::Dolog $lvl + log::logproc $lvl tomlish_log_$lvl + } + + #*** !doctools + #[subsection {Namespace tomlish}] + #[para] Core API functions for tomlish + #[list_begin definitions] + + proc tags {} { + return $::tomlish::tags + } + + #helper function for to_dict + proc _get_keyval_value {keyval_element} { + log::notice ">>> _get_keyval_value from '$keyval_element'<<<" + #find the value (or 2 values if space separated datetime - and stitch back into one) + # 3 is the earliest index at which the value could occur (depending on whitespace) + if {[lindex $keyval_element 2] ne "="} { + error "tomlish _get_keyval_value keyval_element doesn't seem to be a properly structured { = } list" + } + + #review + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keys are lists {parenttable subtable etc} corresponding to parenttable.subtable.etc + } + set sublist [lrange $keyval_element 2 end] + + set values [list] + set value_posns [list] + set posn 0 + foreach sub $sublist { + #note that a barekey/dquotedkey won't occur directly inside a barekey/dquotedkey + switch -exact -- [lindex $sub 0] { + STRING - LITERAL - MULTISTRING - MULTILITERAL - INT - FLOAT - BOOL - DATETIME - TABLE - ARRAY - ITABLE { + lappend values $sub + lappend value_posns $posn + } + default {} + } + incr posn + } + switch -- [llength $values] { + 0 { + error "tomlish Failed to find value element in KEY. '$keyval_element'" + } + 1 { + lassign [lindex $values 0] type value + } + 2 { + #validate than exactly single space was between the two values + lassign $value_posns p1 p2 + if {$p2 != $p1 +2} { + #sanity check + #can probably only get here through manual manipulation of the tomlish list to an unprocessable form + error "tomlish KEY appears to have more than one part - but not separated by whitespace - invalid '$keyval_element'" + } + set between_token [lindex $sublist $p1+1] + if {[lindex $between_token 1] ne " "} { + error "tomlish KEY in 2 parts is not separated by a single space - cannot consider for datetime '$keyval_element'" + } + lassign [lindex $values 0] type_d1 value_d1 + lassign [lindex $values 1] type_d2 value_d2 + if {$type_d1 ne "DATETIME" || $type_d2 ne "DATETIME"} { + error "tomlish KEY in 2 parts does not appear to be datetime '$keyval_element'" + } + set type DATETIME + set value "${value_d1}T${value_d2}" + } + default { + error "tomlish Found multiple value elements in KEY, expected one. (or 2 for space-separated datetime) '$keyval_element'" + } + } + + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + #simple (non-container, no-substitution) datatype + set result [list type $type value $value] + } + STRING - STRINGPART { + set result [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL - LITERALPART { + #REVIEW + set result [list type $type value $value] + } + TABLE { + #invalid? + error "tomlish _get_keyval_value invalid to have type TABLE on rhs of =" + } + ITABLE { + #This one should not be returned as a type value structure! + # + set result [::tomlish::to_dict [ list [lindex $values 0] ]] + } + ARRAY { + #we need to recurse to get the corresponding dict for the contained item(s) + #pass in the whole [lindex $values 0] (type val) - not just the $value! + set prev_tablenames_info $tablenames_info + set tablenames_info [dict create] + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + set tablenames_info $prev_tablenames_info + } + MULTISTRING - MULTILITERAL { + #review - mapping these to STRING might make some conversions harder? + #if we keep the MULTI - we know we have to look for newlines for example when converting to json + #without specific types we'd have to check every STRING - and lose info about how best to map chars within it + set result [list type $type value [ ::tomlish::to_dict [ list [lindex $values 0] ] ]] + } + default { + error "tomlish Unexpected value type '$type' found in keyval '$keyval_element'" + } + } + return $result + } + + + + #to_dict is a *basic* programmatic datastructure for accessing the data. + # produce a dictionary of keys and values from a tomlish tagged list. + # to_dict is primarily for reading toml data. + #Extraneous (not within quoted sections) whitespace and comments are not preserved in this structure, + # so a roundtrip from toml to this datastructure and back to toml will lose whitespace formatting and comments. + # creating/changing toml values can be done directly on a tomlish list if preserving (or adding) formatting/comments is desired. + #A separate package 'tomlish::object' may be needed to allow easier programmatic creating/updating/deleting of data elements whilst preserving (or adding or selectively deleting/editing) such formatting. + # + + #within an ARRAY, we store a list of items such as plain dicts (possibly empty) and {type value } for simple types + #(ARRAYS can be mixed type) + #This means our dict structure should have only ARRAY and simple types which need to be in {type value } form + #A dict within an array encodeded as a type ITABLE value should also parse - but is the unpreferred form - REVIEW test? + + #Namespacing? + #ie note the difference: + #[Data] + #temp = { cpu = 79.5, case = 72.0} + # versus + #[Data] + #temps = [{cpu = 79.5, case = 72.0}] + proc to_dict {tomlish} { + package require dictn + + #keep track of which tablenames have already been directly defined, + # so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid' + #Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here. + #we don't error out just because a previous tablename segment has already appeared. + + #Declaring, Creating, and Defining Tables + #https://github.com/toml-lang/toml/issues/795 + #(update - only Creating and Defining are relevant terminology) + + #review + #tablenames_info keys type created, defined, createdby, definedby, closedby ??? review keys + # [tname] = header_table [[tname]] = header_tablearray + + #consider the following 2 which are legal: + #[table] #'table' created, defined=open type header_table + #x.y = 3 + #[table.x.z] #'table' defined=closed closedby={header_table table.x.z}, 'table.x' created, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k= 22 + # #'table.x.z' defined=closed closedby={eof eof} + + #equivalent datastructure + + #[table] #'table' created, defined=open definedby={header_table table} + #[table.x] #'table' defined=closed closedby={header_table table.x}, 'table.x' created defined=open definedby={header_table table.x} + #y = 3 + #[table.x.z] #'table.x' defined=closed closedby={header_table table.x.z}, 'table.x.z' created defined=open definedby={header_table table.x.z} + #k=22 + + #illegal + #[table] #'table' created and defined=open + #x.y = 3 #'table.x' created first keyval pair defined=open definedby={keyval x.y = 3} + #[table.x.y.z] #'table' defined=closed, 'table.x' closed because parent 'table' closed?, 'table.x.y' cannot be created + #k = 22 + # + ## - we would fail on encountering table.x.y because only table and table.x are effectively tables - but that table.x is closed should be detected (?) + + #illegal + #[table] + #x.y = {p=3} + #[table.x.y.z] + #k = 22 + ## we should fail because y is an inline table which is closed to further entries + + #note: it is not safe to compare normalized tablenames using join! + # e.g a.'b.c'.d is not the same as a.b.c.d + # instead compare {a b.c d} with {a b c d} + # Here is an example where the number of keys is the same, but they must be compared as a list, not a joined string. + #'a.b'.'c.d.e' vs 'a.b.c'.'d.e' + #we need to normalize the tablenames seen so that {"x\ty"} matches {"xy"} + + + + if {[uplevel 1 [list info exists tablenames_info]]} { + upvar tablenames_info tablenames_info + } else { + set tablenames_info [dict create] ;#keyed on tablepath each of which is a list such as {config subgroup etc} (corresponding to config.subgroup.etc) + } + + + log::info "---> to_dict processing '$tomlish'<<<" + set items $tomlish + + foreach lst $items { + if {[lindex $lst 0] ni $::tomlish::tags} { + error "supplied string does not appear to be toml parsed into a tomlish tagged list. Run tomlish::decode::toml on the raw toml data to produce a tomlish list" + } + } + + if {[lindex $tomlish 0] eq "TOMLISH"} { + #ignore TOMLISH tag at beginning + set items [lrange $tomlish 1 end] + } + + set datastructure [dict create] + foreach item $items { + set tag [lindex $item 0] + #puts "...> item:'$item' tag:'$tag'" + switch -exact -- $tag { + KEY - DQKEY - SQKEY { + log::debug "---> to_dict item: processing $tag: $item" + set key [lindex $item 1] + if {$tag eq "DQKEY"} { + set key [::tomlish::utils::unescape_string $key] + } + #!todo - normalize key. (may be quoted/doublequoted) + + if {[dict exists $datastructure $key]} { + error "Duplicate key '$key'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #lassign [_get_keyval_value $item] type val + set keyval_dict [_get_keyval_value $item] + dict set datastructure $key $keyval_dict + } + DOTTEDKEY { + log::debug "---> to_dict item processing $tag: $item" + set dkey_info [tomlish::to_dict::get_dottedkey_info $item] + set dotted_key_hierarchy [dict get $dkey_info keys] + + #a.b.c = 1 + #table_key_hierarchy -> a b + #tleaf -> c + if {[llength $dotted_key_hierarchy] == 0} { + #empty?? probably invalid. review + #This is different to '' = 1 or ''.'' = 1 which have lengths 1 and 2 respectively + error "DOTTED key has no parts - invalid? '$item'" + } elseif {[llength $dotted_key_hierarchy] == 1} { + #dottedkey is only a key - no table component + set table_hierarchy [list] + set tleaf [lindex $dotted_key_hierarchy 0] + } else { + set table_hierarchy [lrange $dotted_key_hierarchy 0 end-1] + set tleaf [lindex $dotted_key_hierarchy end] + } + + #ensure empty tables are still represented in the datastructure + #review - this seems unnecessary? + set pathkeys [list] + foreach k $table_hierarchy { + lappend pathkeys $k + if {![dict exists $datastructure {*}$pathkeys]} { + dict set datastructure {*}$pathkeys [list] + } else { + tomlish::log::notice "to_dict datastructure at key path $pathkeys already had data: [dict get $datastructure {*}$pathkeys]" + } + } + #review? + if {[dict exists $datastructure {*}$table_hierarchy $tleaf]} { + error "Duplicate key '$table_hierarchy $tleaf'. The key already exists at this level in the toml data. The toml data is not valid." + } + + #JMN test 2025 + if {[llength $table_hierarchy]} { + dictn incr tablenames_info [list $table_hierarchy seencount] + } + + set keyval_dict [_get_keyval_value $item] + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + set t [list {*}$table_hierarchy $tleaf] + dictn incr tablenames_info [list $t seencount] + dictn set tablenames_info [list $t closed] 1 + + #review - item is an ITABLE - we recurse here without datastructure context :/ + #overwriting keys? todo ? + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } else { + dict set datastructure {*}$table_hierarchy $tleaf $keyval_dict + } + + } + TABLEARRAY { + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + + set NEST_DICT [dict create] ;#first blush attempt at referencing supertable tablearrays + set tablearrayname [lindex $item 1] + log::debug "---> to_dict processing item TABLENAME (name: $tablearrayname): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablearrayname true] ;#true to normalize + #we expect repeated tablearray entries - each adding a sub-object to the value, which is an array/list. + #tablearrayname is likely to appear multiple times - so unlike a TABLE we don't check for 'defined' for the full name as an indicator of a problem + set supertable [list] + ############## + # [[a.b.c.d]] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of tablearray name $tablearrayname already has data but doesn't appear to be a table - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_supertable_keycollision + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } else { + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + #REVIEW!! + # what happens with from_toml {[[a.b.c]]} {[[a]]} ??? + dictn set tablenames_info [list $supertable type] header_table ;#how do we know it's not going to be a tablearray? + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } else { + #supertable has already been created - and maybe defined - but even if defined we can add subtables unless it is of type itable + #but if it's a tablearray - we need to point to the most 'recently defined table element of the array' + #(another way of saying last member of that array)?? + set supertype [dictn get $tablenames_info [list $supertable type]] + if {$supertype eq "header_tablearray"} { + puts stdout "todict!!! TABLEARRAY nesting required for supertable [join $supertable .]" + puts stdout "todict!!! todo.." + #how to do multilevel nesting?? + set EXISTING_SUPERARRAY_ELEMENTS [dict get $datastructure {*}$supertable value] + dict set NEST_DICT $supertable $EXISTING_SUPERARRAY_ELEMENTS + puts stdout "todict!!! supertable '[join $supertable .]' elements $EXISTING_SUPERARRAY_ELEMENTS" + } + } + } + # + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + #first encounter of this tablearrayname + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[[a]]} + set msg "Cannot create tablearray name $tablearrayname. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablearray_direct_keycollision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no collision - we can create the tablearray and the array in the datastructure + dictn set tablenames_info [list $norm_segments type] header_tablearray + dict set datastructure {*}$norm_segments [list type ARRAY value {}] + set ARRAY_ELEMENTS [list] + } else { + #we have a table - but is it a tablearray? + set ttype [dictn get $tablenames_info [list $norm_segments type]] + #use a tabletype_unknown type for previous 'created' only tables? + if {$ttype ne "header_tablearray"} { + set msg "tablearray name $tablearrayname already appears to be already created as a table not a tablearray - invalid?" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #add to array + #error "add_to_array not implemented" + #{type ARRAY value } + set ARRAY_ELEMENTS [dict get $datastructure {*}$norm_segments value] + } + + + set object [dict create] ;#array context equivalent of 'datastructure' + set objectnames_info [dict create] ;#array contex equivalent of tablenames_info + + #add to ARRAY_ELEMENTS and write back in to datastructure. + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #MAINTENANCE: temp copy from TABLE + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + #set supertable $norm_segments + set supertable [list] ;#disconnect from main structure - each array element is a new context for key paths! + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey '$dottedkeyname' kv: $keyval_dict" + #dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + #wrong + #TODO!!!!!!!!!!!!! + #lappend ARRAY_ELEMENTS [list $dottedkeyname $keyval_dict] + dict set object $dottedkeyname $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + TABLE { + #we should be able to process tablearray subtables either as part of the tablearray record, or independently. + #(or even a mixture of both, although that is somewhat an edge case) + #[[fruit]] + #x=1 + # [fruit.metadata] + # [fruit.otherdata] + + #when processing a dict destined for the above - the tomlish generator (e.g from_dict) + #should create as 1 or 3 records (but could create 2 records if there was an unrelated table in between the subtables) + #choices: all in tablearray record, tablearray + 1 or 2 table records. + # + #We are going the other way here - so we just need to realize the list of tables 'belonging' to this tablearray might not be complete. + # + #the subtable names must be prefixed with the tablearray - we should validate that for any contained TABLE records + + } + default { + error "Sub element of type '$type' not understood in tablearray context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #todo? + ##end of TABLE record - equivalent of EOF or next header - close off the dottedtables + #foreach dtablepath $dottedtables_defined { + # dictn set tablename_info [list $dtablepath defined] closed + #} + + if {[dict size $NEST_DICT]} { + puts "reintegrate?? $NEST_DICT" + #todo - more - what if multiple in hierarchy? + dict for {superpath existing_elements} $NEST_DICT { + #objects stored directly as dicts in ARRAY value + set lastd [lindex $existing_elements end] + #insufficient.. + #dict set lastd [lindex $norm_segments end] [list type ITABLE value $object] + dict set lastd [lindex $norm_segments end] $object + #set lastd [dict merge $lastd $object] + lset existing_elements end $lastd + dict set datastructure {*}$superpath [list type ARRAY value $existing_elements] + } + } else { + #lappend ARRAY_ELEMENTS [list type ITABLE value $object] + lappend ARRAY_ELEMENTS $object + dict set datastructure {*}$norm_segments [list type ARRAY value $ARRAY_ELEMENTS] + } + } + TABLE { + set tablename [lindex $item 1] + set dottedtables_defined [list] ;#for closing off at end by setting 'defined' + #As our TABLE record contains all it's child DOTTEDKEY records - this should be equivalent to setting them as defined at EOF or next header. + + log::debug "---> to_dict processing item TABLE (name: $tablename): $item" + set norm_segments [::tomlish::to_dict::tablename_split $tablename true] ;#true to normalize + + set T_DEFINED [dictn getdef $tablenames_info [list $norm_segments defined] NULL] + if {$T_DEFINED ne "NULL"} { + #our tablename e.g [a.b.c.d] declares a space to 'define' subkeys - but there has already been a definition space for this path + set msg "Table name $tablename has already been directly defined in the toml data. Invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE TABLEREDEFINED} $msg + } + + + set name_segments [::tomlish::to_dict::tablename_split $tablename 0] ;#unnormalized e.g ['a'."b".c.d] -> 'a' "b" c d + #results of tablename_split 0 are 'raw' - ie some segments may be enclosed in single or double quotes. + + + set supertable [list] + ############## + # [a.b.c.d] + # norm_segments = {a b c d} + #check a {a b} {a b c} <---- supertables of a.b.c.d + ############## + foreach normseg [lrange $norm_segments 0 end-1] { + lappend supertable $normseg + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this path doesn't yet exist + if {[dict exists $datastructure {*}$supertable]} { + #There is data though - so it must have been created as a keyval + set msg "Supertable [join $supertable .] of table name $tablename already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] header_table + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } else { + #supertable has already been created - and may be defined - but even if defined we can add subtables unless it is of type itable + + } + } + #table [a.b.c.d] hasn't been defined - but may have been 'created' already by a longer tablename + # - or may have existing data from a keyval + if {![dictn exists $tablenames_info [list $norm_segments type]]} { + if {[dict exists $datastructure {*}$norm_segments]} { + #e.g from_toml {a=1} {[a]} + set msg "Cannot create table name $tablename. Key already has data but key doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + #test: datastructure_tablename_keyval_collision_error + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #no data or previously created table + dictn set tablenames_info [list $norm_segments type] header_table + + #We are 'defining' this table's keys and values here (even if empty) + dict set datastructure {*}$norm_segments [list] ;#ensure table still represented in datastructure even if we add no keyvals here + } + dictn set tablenames_info [list $norm_segments defined] open + log::debug ">>> to_dict >>>>>>>>>>>>>>>>> normalized table key hierarchy : $norm_segments" + + #now add the contained elements + foreach element [lrange $item 2 end] { + set type [lindex $element 0] + log::debug "----> todict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + #convert to function: data needed? element, norm_segments refs to: tablename_info datastructure ??? + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + #e.g1 keys {x.y y} keys_raw {'x.y' "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + #e.g2 keys {x.y y} keys_raw {{"x.y"} "a\tb"} keys {x.y {a b}} (keys_raw has escape, keys has literal tab char) + + #[a.b] + #t1.t2.dottedtable.k = "val" + #we have already checked supertables a {a b} + #We need to check {a b t1} & {a b t2} ('creation' only) + #and then 'dottedtable' is 'defined' while k is an ordinary key in dottedtable + + #note we also get here as a 'dottedkey' with a simple + #[a.b] + #k = "val" + + set all_dotted_keys [dict get $dkey_info keys] + set dottedkeyname [join $all_dotted_keys .] + #obsolete + set nonleaf_keys [lrange $all_dotted_keys 0 end-1] ;#may be empty + + if {[llength $all_dotted_keys] > 1} { + #dottedtable.k=1 + #tX.dottedtable.k=1 + #etc + + set defines_a_table 1 + #Wrap in a list so we can detect 'null' equivalent. + #We can't use empty string as that's a valid dotted key segment + set dottedtable_bag [list [lindex $all_dotted_keys end-1]] + set dotparents [lrange $all_dotted_keys 0 end-2] + } else { + #basic case - not really a 'dotted' key + #a = 1 + set defines_a_table 0 + set dottedtable_bag [list] ;#empty bag + set dotparents [list] + } + #assert dottedtable_bag only ever holds 0 or 1 elements + set leaf_key [lindex $all_dotted_keys end] + + #we've already tested the table keys that got us here.. but not the dottedkey segments (if any) prior to dottedtable & leaf_key + set supertable $norm_segments + foreach normkey $dotparents { + lappend supertable $normkey + if {![dictn exists $tablenames_info [list $supertable type]]} { + #supertable with this combined path (table norm_segments plus parts of dottedkey) not yet 'created' + if {[dict exists $datastructure {*}$supertable]} { + #There is data so it must have been created as a keyval + set msg "Supertable [join $supertable .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #here we 'create' it, but it's not being 'defined' ie we're not setting keyvals for it here + dictn set tablenames_info [list $supertable type] unknown_table ;#REVIEW + #ensure empty tables are still represented in the datastructure + dict set datastructure {*}$supertable [list] + } + } + if {[llength $dottedtable_bag] == 1} { + set dottedtable [lindex $dottedtable_bag 0] + set dottedpath [list {*}$norm_segments {*}$dotparents $dottedtable] ;#full path to dottedtable + #our dotted key is attempting to define a table + if {![dictn exists $tablenames_info [list $dottedpath type]]} { + #first one - but check datastructure for collisions + if {[dict exists $datastructure {*}$dottedpath]} { + set msg "Supertable [join $dottedpath .] of dotted key $dottedkeyname already has data but doesn't appear to be a table (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + #raise a specific type of error for tests to check + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + #'create' the table + dictn set tablenames_info [list $dottedpath type] dottedkey_table + #don't actually set 'defined' here.. use the end of TABLE record to close them off by looking at this list + lappend dottedtables_defined $dottedpath + # + } else { + #exists - but might be from another dottedkey within the current header section + #the table is open for adding keys until the next 'header' section ([tablename] / [[tablearray]]) + #check for 'defined' closed (or just existence) + if {[dictn get $tablenames_info [list $dottedpath type]] eq "dottedkey_table"} { + #right type - but make sure it's from this header section - i.e defined not set + set definedstate [dictn getdef $tablenames_info [list $dottedpath defined] NULL] + if {$definedstate ne "NULL"} { + #collision with some other dottedkey + set msg "Table $dottedpath represented by dottedkey $dottedkeyname has been 'defined' elsewhere (keycollision) - invalid" + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + } + } + } + #assert - dottedkey represents a key val pair that can be added + + + if {[dict exists $datastructure {*}$norm_segments {*}$all_dotted_keys]} { + set msg "Duplicate key '$norm_segments $all_dotted_keys'. The key already exists at this level in the toml data. The toml data is not valid." + append msg \n [tomlish::dict::_show_tablenames $tablenames_info] + return -code error -errorcode {TOMLISH STRUCTURE KEYCOLLISION} $msg + } + + set keyval_dict [_get_keyval_value $element] + #keyval_dict is either a {type value } + #or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level + #punk::dict::is_tomlish_typeval can distinguish + puts stdout "to_dict>>> TABLE/dottedkey $dottedkeyname kv: $keyval_dict" + dict set datastructure {*}$norm_segments {*}$all_dotted_keys $keyval_dict + + #remove ? + if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} { + #the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys + # inner structure will contain {type value } if all leaves are not empty ITABLES + set tkey [list {*}$norm_segments {*}$all_dotted_keys] + #lappend tablenames_info [list {*}$norm_segments {*}$dkeys $leaf_key] + + #by not creating a tablenames_info record - we effectively make it closed anyway? + #it should be detected as a key + #is there any need to store tablenames_info for it?? + #REVIEW + + ##TODO - update? + #dictn incr tablenames_info [list $tkey seencount] + ##if the keyval_dict is not a simple type x value y - then it's an inline table ? + ##if so - we should add the path to the leaf_key as a closed table too - as it's not allowed to have more entries added. + #dictn set tablenames_info [list $tkey closed] 1 + } + + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in table context. Expected only DOTTEDKEY,NEWLINE,COMMENT,WS" + } + } + } + + #end of TABLE record - equivalent of EOF or next header - close off the dottedtables + foreach dtablepath $dottedtables_defined { + dictn set tablename_info [list $dtablepath defined] closed + } + + + #review??? + #now make sure we add an empty value if there were no contained elements! + #!todo. + } + ITABLE { + #SEP??? + set datastructure [list] + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + DOTTEDKEY { + set dkey_info [tomlish::to_dict::get_dottedkey_info $element] + set dotted_key_hierarchy [dict get $dkey_info keys] + set leaf_key [lindex $dotted_key_hierarchy end] + set dkeys [lrange $dotted_key_hierarchy 0 end-1] + + #ensure empty keys are still represented in the datastructure + set table_keys [list] ;#We don't know the context - next level up will have to check for key collisions? + set test_keys $table_keys + foreach k $dkeys { + lappend test_keys $k + if {![dict exists $datastructure {*}$test_keys]} { + dict set datastructure {*}$test_keys [list] + } else { + tomlish::log::notice "to_dict datastructure at (DOTTEDKEY) subkey $test_keys already had data: [dict get $datastructure {*}$test_keys]" + } + } + + if {[dict exists $datastructure {*}$table_keys {*}$dkeys $leaf_key]} { + error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid." + } + set keyval_dict [_get_keyval_value $element] + dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict + } + NEWLINE - COMMENT - WS { + #ignore + } + default { + error "Sub element of type '$type' not understood in ITABLE context. Expected only KEY,DQKEY,SQKEY,NEWLINE,COMMENT,WS" + } + } + } + } + ARRAY { + #arrays in toml are allowed to contain mixtures of types + set datastructure [list] + log::debug "--> processing array: $item" + + foreach element [lrange $item 1 end] { + set type [lindex $element 0] + log::debug "----> tododict processing $tag subitem $type processing contained element $element" + switch -exact -- $type { + INT - FLOAT - BOOL - DATETIME { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + STRING { + set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::utils::unescape_string $value]] + } + LITERAL { + set value [lindex $element 1] + lappend datastructure [list type $type value $value] + } + ITABLE { + #anonymous table + #lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + lappend datastructure [::tomlish::to_dict [list $element]] ;#store itables within arrays as raw dicts (possibly empty) + } + TABLE { + #invalid? shouldn't be output from from_dict - but could manually be constructed as such? review + #doesn't make sense as table needs a name? + #take as synonym for ITABLE? + error "to_dict TABLE within array unexpected" + } + ARRAY - MULTISTRING - MULTILITERAL { + #set value [lindex $element 1] + lappend datastructure [list type $type value [::tomlish::to_dict [list $element]]] + } + WS - SEP - NEWLINE - COMMENT { + #ignore whitespace, commas, newlines and comments + } + default { + error "Unexpected value type '$type' found in array" + } + } + } + } + MULTILITERAL { + #triple squoted string + #first newline stripped only if it is the very first element + #(ie *immediately* following the opening delims) + #All whitespace other than newlines is within LITERALPARTS + # ------------------------------------------------------------------------- + #todo - consider extension to toml to allow indent-aware multiline literals + # how - propose as issue in toml github? Use different delim? e.g ^^^ ? + #e.g + # xxx=?'''abc + # def + # etc + # ''' + # - we would like to trimleft each line to the column following the opening delim + # ------------------------------------------------------------------------- + + log::debug "---> todict processing multiliteral: $item" + set parts [lrange $item 1 end] + if {[lindex $parts 0 0] eq "NEWLINE"} { + set parts [lrange $parts 1 end] ;#skip it + } + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + switch -exact -- $type { + LITERALPART { + append stringvalue [lindex $element 1] + } + NEWLINE { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + MULTISTRING { + #triple dquoted string + log::debug "---> to_dict processing multistring: $item" + set stringvalue "" + set idx 0 + set parts [lrange $item 1 end] + for {set idx 0} {$idx < [llength $parts]} {incr idx} { + set element [lindex $parts $idx] + set type [lindex $element 0] + #We use STRINGPART in the tomlish representation as a distinct element to STRING - which would imply wrapping quotes to be reinserted + switch -exact -- $type { + STRING { + #todo - do away with STRING ? + #we don't build MULTISTRINGS containing STRING - but should we accept it? + tomlish::log::warn "double quoting a STRING found in MULTISTRING - should be STRINGPART?" + append stringvalue "\"[::tomlish::utils::unescape_string [lindex $element 1]]\"" + } + STRINGPART { + append stringvalue [::tomlish::utils::unescape_string [lindex $element 1]] + } + CONT { + #When the last non-whitespace character on a line is an unescaped backslash, + #it will be trimmed along with all whitespace (including newlines) up to the next non-whitespace character or closing delimiter + # review - we allow some whitespace in stringpart elements - can a stringpart ever be all whitespace? + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + append stringvalue "\\" ;#add the sep + } else { + #skip over ws without emitting + set idx [llength $parts] + } + } else { + set parts_til_nl [lrange $parts 0 $next_nl-1] + set non_ws [lsearch -index 0 -start $idx+1 -not $parts_til_nl WS] + if {$non_ws >= 0} { + append stringvalue "\\" + } else { + #skip over ws on this line + set idx $next_nl + #then have to check each subsequent line until we get to first non-whitespace + set trimming 1 + while {$trimming && $idx < [llength $parts]} { + set next_nl [lsearch -index 0 -start $idx+1 $parts NEWLINE] + if {$next_nl == -1} { + #last line + set non_ws [lsearch -index 0 -start $idx+1 -not $parts WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + } else { + set idx [llength $parts] + } + set trimming 0 + } else { + set non_ws [lsearch -index 0 -start $idx+1 -not [lrange $parts 0 $next_nl-1] WS] + if {$non_ws >= 0} { + set idx [expr {$non_ws -1}] + set trimming 0 + } else { + set idx $next_nl + #keep trimming + } + } + } + } + } + } + NEWLINE { + #if newline is first element - it is not part of the data of a multistring + if {$idx > 0} { + set val [lindex $element 1] + if {$val eq "nl"} { + append stringvalue \n + } else { + append stringvalue \r\n + } + } + } + WS { + append stringvalue [lindex $element 1] + } + default { + error "Unexpected value type '$type' found in multistring" + } + } + } + set datastructure $stringvalue + } + WS - COMMENT - NEWLINE { + #ignore + } + default { + error "Unexpected tag '$tag' in Tomlish list '$tomlish'" + } + } + } + return $datastructure + } + + + proc _from_dictval_tomltype {parents tablestack keys typeval} { + set type [dict get $typeval type] + set val [dict get $typeval value] + switch -- $type { + ARRAY { + set subitems [list] + foreach item $val { + lappend subitems [_from_dictval [list {*}$parents ARRAY] $tablestack $keys $item] SEP + } + if {[lindex $subitems end] eq "SEP"} { + set subitems [lrange $subitems 0 end-1] + } + return [list ARRAY {*}$subitems] + } + ITABLE { + if {$val eq ""} { + return ITABLE + } else { + return [_from_dictval [list {*}$parents ITABLE] $tablestack $keys $val] + } + } + MULTISTRING { + #value is a raw string that isn't encoded as tomlish + #create a valid toml snippet with the raw value and decode it to the proper tomlish MULTISTRING format + #We need to convert controls in $val to escape sequences - except for newlines + # + #consider an *option* to reformat for long lines? (perhaps overcomplex - byte equiv - but may fold in ugly places) + #we could use a line-length limit to decide when to put in a "line ending backslash" + #and even format it with a reasonable indent so that proper CONT and WS entries are made (?) REVIEW + # + #TODO + set tomlpart "x=\"\"\"\\\n" + append tomlpart $val "\"\"\"" + set tomlish [tomlish::decode::toml $tomlpart] + #e.g if val = " etc\nblah" + #TOMLISH {DOTTEDKEY {{KEY x}} = {MULTISTRING CONT {NEWLINE LF} {WS { }} {STRINGPART etc} {NEWLINE lf} {STRINGPART blah} } } + #lindex 1 3 is the MULTISTRING tomlish list + return [lindex $tomlish 1 3] + } + MULTILITERAL { + #MLL string can contain newlines - but still no control chars + #todo - validate + set tomlpart "x='''\n" + append tomlpart $val ''' + set tomlish [tomlish::decode::toml $tomlpart] + return [lindex $tomlish 1 3] + } + LITERAL { + #from v1.0 spec - "Control characters other than tab are not permitted in a literal string" + #(This rules out raw ANSI SGR - which is somewhat restrictive - but perhaps justified for a config format + # as copy-pasting ansi to a config value is probably not always wise, and it's not something that can be + # easily input via a text editor. ANSI can go in Basic strings using the \e escape if that's accepted v1.1?) + #we could choose to change the type to another format here when encountering invalid chars - but that seems + #like too much magic. We elect to error out and require the dict to have valid data for the types it specifies. + if {[string first ' $val] >=0} { + error "_from_dictval_tomltype error: single quote found in LITERAL - cannot encode dict to TOML-VALID TOMLISH" + } + #detect control chars other than tab + #for this we can use rawstring_to_Bstring_with_escaped_controls - even though this isn't a Bstring + #we are just using the map to detect a difference. + set testval [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val] + if {$testval ne $val} { + #some escaping would have to be done if this value was destined for a Bstring... + #therefor this string has controls and isn't suitable for a LITERAL according to the specs. + error "_from_dictval_tomltype error: control chars (other than tab) found in LITERAL value - cannot encode dict to TOML-VALID TOMLISH" + } + return [list LITERAL $val] + } + STRING { + return [list STRING [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $val]] + } + INT { + if {![::tomlish::utils::is_int $val]} { + error "_from_dictval_tomltype error: bad INT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list INT $val] + } + FLOAT { + if {![::tomlish::utils::is_float $val]} { + error "_from_dictval_tomltype error: bad FLOAT value '$val' - cannot encode dict to TOML-VALID TOMLISH" + } + return [list FLOAT $val] + } + default { + if {$type ni [::tomlish::tags]} { + error "_from_dictval_tomltype error: Unrecognised typename '$type' in {type value } - cannot encode dict to TOML-VALID TOMLISH" + } + return [list $type $val] + } + } + } + + #take a raw string and classify: result is a 2 element list comprised of KEY|SQKEY|DQKEY and the value being the appropriate inner string + proc _from_dict_classify_key {rawval} { + if {![::tomlish::utils::is_barekey $rawval]} { + #requires quoting + # + #Any dot in the key would have been split by to_dict - so if it's present here it's part of this key - not a level separator! + # + #we'll use a basic mechanisms for now to determine the type of quoting + # - whether it has any single quotes or not. + # (can't go in an SQKEY) + # - whether it has any chars that require quoting when in a Bstring + # (if so - then its visual representation might be unsuitable for a key in a toml text file, so escape and put in DQKEY instead of literal SQKEY) + #todo - more? + #REVIEW - the backslash might often be in things like a regex or windows path - which is often better expressed in a literal SQKEY + # from literal examples: + # 'c:\Users\nodejs\templates' + # '<\i\c*\s*>' + #If these are in *keys* our basic test will express these as: + # "c:\\Users\\nodejs\\templates" + # "<\\i\\c*\\s*>" + # This still works - but a smarter test might determine when SQKEY is the better form? + #when coming from external systems - can we even know if the value was already escaped? REVIEW + #Probably when coming from json - we know it's already escaped - and so we build our dict converting keys to unescaped + #TODO - clarify in documentation that keys resulting from to_dict are in 'normalized' (unescaped) form + # + #For keys - we currently (2025) are only allowed barekeys,basic strings and literal strings. (no multiline forms) + set k_escaped [tomlish::utils::rawstring_to_Bstring_with_escaped_controls $rawval] + if {[string length $k_escaped] != [string length $rawval]} { + #escaping made a difference + set has_escape_requirement 1 + } else { + set has_escape_requirement 0 + } + if {[string first ' $rawval] >=0 || $has_escape_requirement} { + #basic string + # (any ANSI SGR sequence will end up here in escaped form ) + return [list DQKEY $k_escaped] + } else { + #literal string + return [list SQKEY $rawval] + } + } else { + return [list KEY $rawval] + } + } + + #the quoting implies the necessary escaping for DQKEYs + proc _from_dict_join_and_quote_raw_keys {rawkeylist} { + set result "" + foreach rk $rawkeylist { + lassign [_from_dict_classify_key $rk] type val + switch -- $type { + SQKEY { + append result "'$val'." + } + DQKEY { + append result "\"$val\"." + } + KEY { + append result "$val." + } + } + } + return [string range $result 0 end-1] + } + proc _from_dictval {parents tablestack keys vinfo} { + set k [lindex $keys end] + set K_PART [_from_dict_classify_key $k] ;#get [list SQKEY ] + puts stderr "---parents:'$parents' keys:'$keys' vinfo: $vinfo---" + puts stderr "---tablestack: $tablestack---" + set result [list] + set lastparent [lindex $parents end] + if {$lastparent in [list "" do_inline]} { + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + set type [dict get $vinfo type] + #treat ITABLE differently? + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result DOTTEDKEY [list $K_PART {WS { }}] = {WS { }} $sublist {NEWLINE lf} + } else { + if {$vinfo ne ""} { + + #set result [list DOTTEDKEY [list [list KEY $k]] = ] + #set records [list ITABLE] + + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + + if {$lastparent eq "do_inline"} { + set result [list DOTTEDKEY [list $K_PART] =] + set records [list ITABLE] + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + set result [list TABLE $tname {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $k]] + set records [list] + } + + + + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + #(SQKEY & DQKEY do not have the enclosing quotes in their returned val) + #if {[regexp {\s} $vk] || [string first . $vk] >= 0} { + # set VK_PART [list SQKEY $vk] + #} else { + # set VK_PART [list KEY $vk] + #} + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + #REVIEW - we could detect if value is an array of objects, + #and depending on parent context - emit a series of TABLEARRAY records instead of a DOTTEDKEY record containing an ARRAY of objects + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist] + } else { + if {$vv eq ""} { + #experimental + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline KEY $vk (tablestack:$tablestack)" + #set tname [tomlish::dict::name_from_tablestack [list {*}$tablestack [list T $vk]]] + + #we can't just join normalized keys - need keys with appropriate quotes and escapes + #set tname [join [list {*}$keys $vk] .] ;#WRONG + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + } else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + set tablestack [list {*}$tablestack [list I $vk]] + } + } else { + if { 0 } { + #experiment.. sort of getting there. + if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + puts stderr "_from_dictval could uninline2 KEYS [list {*}$keys $vk] (tablestack:$tablestack)" + set tq [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + set record [list TABLE $tq {NEWLINE lf}] + set tablestack [list {*}$tablestack [list T $vk]] + + #review - todo? + set dottedkey_value [_from_dictval [list {*}$parents TABLE] $tablestack [list {*}$keys $vk] $vv] + lappend record {*}$dottedkey_value + + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } else { + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + } + if {$dictidx != $lastidx} { + #lappend record SEP + if {$lastparent eq "do_inline"} { + lappend record SEP + } else { + lappend record {NEWLINE lf} + } + } + lappend records $record + incr dictidx + } + if {$lastparent eq "do_inline"} { + lappend result $records {NEWLINE lf} + } else { + lappend result {*}$records {NEWLINE lf} + } + } else { + if {$lastparent eq "do_inline"} { + lappend result DOTTEDKEY [list $K_PART] = ITABLE {NEWLINE lf} + } else { + set tname [_from_dict_join_and_quote_raw_keys [list $k]] + lappend result TABLE $tname {NEWLINE lf} + } + } + } + } else { + #lastparent is not toplevel "" or "do_inline" + if {[tomlish::dict::is_tomlish_typeval $vinfo]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo] + lappend result {*}$sublist + } else { + if {$lastparent eq "TABLE"} { + #review + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + set dottedkey_value [_from_dictval [list {*}$parents DOTTEDKEY] $tablestack [list {*}$keys $vk] $vv] + lappend result [list DOTTEDKEY [list $VK_PART] = $dottedkey_value {NEWLINE lf}] + } + } else { + if {$vinfo ne ""} { + set lastidx [expr {[dict size $vinfo] -1}] + set dictidx 0 + set sub [list] + #REVIEW + #set result $lastparent ;#e.g sets ITABLE + set result ITABLE + set last_tomltype_posn [tomlish::dict::last_tomltype_posn $vinfo] + dict for {vk vv} $vinfo { + set VK_PART [_from_dict_classify_key $vk] ;#get [list SQKEY ] + if {[tomlish::dict::is_tomlish_typeval $vv]} { + #type x value y + set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv] + set record [list DOTTEDKEY [list $VK_PART] = $sublist] + } else { + if {$vv eq ""} { + #can't just uninline at this level + #we need a better method to query main dict for uninlinability at each level + # (including what's been inlined already) + #if {[lindex $parents 0] eq "" && $dictidx > $last_tomltype_posn} { + # puts stderr "_from_dictval uninline2 KEY $keys" + # set tname [_from_dict_join_and_quote_raw_keys [list {*}$keys $vk]] + # set record [list TABLE $tname {NEWLINE lf}] + # set tablestack [list {*}$tablestack [list T $vk]] + #} else { + set record [list DOTTEDKEY [list $VK_PART] = ITABLE] + #} + } else { + #set sub [_from_dictval ITABLE $vk $vv] + set dottedkey_value [_from_dictval [list {*}$parents ITABLE] $tablestack [list {*}$keys $vk] $vv] + #set record [list DOTTEDKEY [list $VK_PART] = ITABLE $dottedkey_value] + set record [list DOTTEDKEY [list $VK_PART] = $dottedkey_value] + } + } + if {$dictidx != $lastidx} { + lappend record SEP + } + lappend result $record + incr dictidx + } + } else { + puts stderr "table x-1" + lappend result DOTTEDKEY [list $K_PART] = ITABLE + } + } + } + } + return $result + } + + + proc from_dict {d} { + #consider: + # t1={a=1,b=2} + # x = 1 + #If we represent t1 as an expanded table we get + # [t1] + # a=1 + # b=2 + # x=1 + # --- which is incorrect - as x was a toplevel key like t1! + #This issue doesn't occur if x is itself an inline table + # t1={a=1,b=2} + # x= {no="problem"} + # + # (or if we were to reorder x to come before t1) + + #As the dictionary form doesn't distinguish the structure used to create tables {[table1]\nk=v} vs inline {table1={k=v}} + #Without a solution, from_dict would have to always produce the inline form for toplevel tables unless we allowed re-ordering, + #which is unpreferred here. + + #A possible solution: + #scan the top level to see if all (trailing) elements are themselves dicts + # (ie not of form {type XXX value yyy}) + # + # A further point is that if all root level values are at the 'top' - we can treat lower table-like structures as {[table]} elements + #ie we don't need to force do_inline if all the 'simple' keys are before any compound keys + + #set root_has_values 0 + #approach 1) - the naive approach - forces inline when not always necessary + #dict for {k v} $d { + # if {[llength $v] == 4 && [lindex $v 0] eq "type"} { + # set root_has_values 1 + # break + # } + #} + + + #approach 2) - track the position of last {type x value y} in the dictionary built by to_dict + # - still not perfect. Inlines dotted tables unnecessarily + #This means from_dict doesn't produce output optimal for human editing. + set last_simple [tomlish::dict::last_tomltype_posn $d] + + + ## set parent "do_inline" ;#a value used in _from_dictval to distinguish from "" or other context based parent values + #Any keys that are themselves tables - will need to be represented inline + #to avoid reordering, or incorrect assignment of plain values to the wrong table. + + ## set parent "" + #all toplevel keys in the dict structure can represent subtables. + #we are free to use {[tablename]\n} syntax for toplevel elements. + + + set tomlish [list TOMLISH] + set dictposn 0 + set tablestack [list [list T root]] ;#todo + dict for {t tinfo} $d { + if {$last_simple > $dictposn} { + set parents [list do_inline] + } else { + set parents [list ""] + } + set keys [list $t] + #review - where to make decision on + # DOTTEDKEY containing array of objs + #vs + # list of TABLEARRAY records + #At least for the top + set trecord [_from_dictval $parents $tablestack $keys $tinfo] + lappend tomlish $trecord + incr dictposn + } + return $tomlish + } + + proc json_to_toml {json} { + #*** !doctools + #[call [fun json_to_toml] [arg json]] + #[para] + + set tomlish [::tomlish::from_json $json] + set toml [::tomlish::to_toml $tomlish] + } + + #TODO use huddle? + proc from_json {json} { + #set jstruct [::tomlish::json_struct $json] + #return [::tomlish::from_json_struct $jstruct] + package require huddle + package require huddle::json + set h [huddle::json::json2huddle parse $json] + + } + + proc from_json_struct {jstruct} { + package require fish::json_toml + return [fish::json_toml::jsonstruct2tomlish $jstruct] + } + + proc toml_to_json {toml} { + set tomlish [::tomlish::from_toml $toml] + return [::tomlish::get_json $tomlish] + } + + proc get_json {tomlish} { + package require fish::json + set d [::tomlish::to_dict $tomlish] + + #return [::tomlish::dict_to_json $d] + return [fish::json::from "struct" $d] + } + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +namespace eval tomlish::build { + #STRING,INT,FLOAT,BOOL, DATETIME - simple wrappers for completeness + # take a value of the appropriate type and wrap as a tomlish tagged item + proc STRING {s} { + return [list STRING [::tomlish::utils::rawstring_to_Bstring_with_escaped_controls $s]] + } + proc LITERAL {litstring} { + error todo + } + + proc INT {i} { + #whole numbers, may be prefixed with a + or - + #Leading zeros are not allowed + #Hex,octal binary forms are allowed (toml 1.0) + #We will error out on encountering commas, as commas are interpreted differently depending on locale (and don't seem to be supported in the toml spec anyway) + #!todo - Tcl can handle bignums - bigger than a 64bit signed long as specified in toml. + # - We should probably raise an error for number larger than this and suggest the user supply it as a string? + if {[tcl::string::last , $i] > -1} { + error "Unable to interpret '$i' as an integer. Use underscores if you need a thousands separator [::tomlish::parse::report_line]" + } + if {![::tomlish::utils::int_validchars $i]} { + error "Unable to interpret '$i' as an integer. Only 0-9 + 1 _ characters are acceptable. [::tomlish::parse::report_line]" + } + + if {[::tomlish::utils::is_int $i]} { + return [list INT $i] + } else { + error "'$i' is not a valid integer as per the Toml spec. [::tomlish::parse::report_line]" + } + + } + + proc FLOAT {f} { + #convert any non-lower case variants of special values to lowercase for Toml + if {[::tcl::string::tolower $f] in {nan +nan -nan inf +inf -inf}} { + return [list FLOAT [tcl::string::tolower $f]] + } + if {[::tomlish::utils::is_float $f]} { + return [list FLOAT $f] + } else { + error "Unable to interpret '$f' as Toml float. Check your input, or check that tomlish is able to handle all Toml floats properly [::tomlish::parse::report_line]" + } + } + + proc DATETIME {str} { + if {[::tomlish::utils::is_datetime $str]} { + return [list DATETIME $str] + } else { + error "Unable to interpret '$str' as Toml datetime. Check your input, or check that tomlish is able to handle all Toml datetimes properly [::tomlish::parse::report_line]" + } + } + + proc BOOLEAN {b} { + #convert any Tcl-acceptable boolean to boolean as accepted by toml - lower case true/false + if {![tcl::string::is boolean -strict $b]} { + error "Unable to convert '$b' to Toml boolean true|false. [::tomlish::parse::report_line]" + } else { + if {$b && 1} { + return [::list BOOL true] + } else { + return [::list BOOL false] + } + } + } + + #REVIEW + #Take tablename followed by + # a) *tomlish* name-value pairs e.g table mydata [list KEY item11 = [list STRING "test"]] {KEY item2 = [list INT 1]} + # (accept also key value {STRING }) + # b) simple 2-element tcl lists being name & *simple* value pairs for which basic heuristics will be used to determine types + proc _table {name args} { + set pairs [list] + foreach t $args { + if {[llength $t] == 4} { + if {[tcl::string::tolower [lindex $t 0]] ne "key" || [tcl::string::tolower [lindex $t 2]] ni "= value"} { + error "Only items tagged as KEY = currently accepted as name-value pairs for table command" + } + lassign $t _k keystr _eq valuepart + if {[llength $valuepart] != 2} { + error "supplied value must be typed. e.g {INT 1} or {STRING test}" + } + lappend pairs [list KEY $keystr = $valuepart] + } elseif {[llength $t] == 2} { + #!todo - type heuristics + lassign $t n v + lappend pairs [list KEY $n = [list STRING $v]] + } else { + error "'KEY = { toml but + # the first newline is not part of the data. + # we elect instead to maintain a basic LITERALPART that must not contain newlines.. + # and to compose MULTILITERAL of multiple NEWLINE LITERALPART parts, + #with the datastructure representation dropping the first newline (if immediately following opening delim) when building the value. + set literal "" + foreach part [lrange $item 1 end] { + append literal [::tomlish::encode::tomlish [list $part] $nextcontext] + } + append toml '''$literal''' + } + INT - + BOOL - + FLOAT - + DATETIME { + append toml [lindex $item 1] + } + INCOMPLETE { + error "cannot process tomlish term tagged as INCOMPLETE" + } + COMMENT { + append toml "#[lindex $item 1]" + } + BOM { + #Byte Order Mark may appear at beginning of a file. Needs to be preserved. + append toml "\uFEFF" + } + default { + error "Not a properly formed 'tomlish' taggedlist.\n '$list'\n Unknown tag '[lindex $item 0]'. See output of \[tomlish::tags\] command." + } + } + + } + return $toml + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::encode ---}] +} +#fish toml from tomlish + +#(encode tomlish as toml) +interp alias {} tomlish::to_toml {} tomlish::encode::tomlish + +# + + +namespace eval tomlish::decode { + #*** !doctools + #[subsection {Namespace tomlish::decode}] + #[para] + #[list_begin definitions] + + #return a Tcl list of tomlish tokens + #i.e get a standard list of all the toml terms in string $s + #where each element of the list is a *tomlish* term.. i.e a specially 'tagged' Tcl list. + #(simliar to a tcl 'Huddle' - but also supporting whitespace preservation) + # ---------------------------------------------------------------------------------------------- + # NOTE: the production of tomlish from toml source doesn't indicate the toml source was valid!!! + # e.g we deliberately don't check certain things such as duplicate table declarations here. + # ---------------------------------------------------------------------------------------------- + #Part of the justification for this is that as long as the syntax is toml shaped - we can load files which violate certain rules and allow programmatic manipulation. + # (e.g perhaps a toml editor to highlight violations for fixing) + # A further stage is then necessary to load the tomlish tagged list into a data structure more suitable for efficient query/reading. + # e.g dicts or an object oriented structure + #Note also - *no* escapes in quoted strings are processed. This is up to the datastructure stage + #e.g to_dict will substitute \r \n \uHHHH \UHHHHHHH etc + #This is important for tomlish to maintain the ability to perform competely lossless round-trips from toml to tomlish and back to toml. + # (which is handy for testing as well as editing some part of the structure with absolutely no effect on other parts of the document) + #If we were to unescape a tab character for example + # - we have no way of knowing if it was originally specified as \t \u0009 or \U00000009 or directly as a tab character. + # For this reason, we also do absolutely no line-ending transformations based on platform. + # All line-endings are maintained as is, and even a file with mixed lf crlf line-endings will be correctly interpreted and can be 'roundtripped' + + proc toml {args} { + #*** !doctools + #[call [fun toml] [arg arg...]] + #[para] return a Tcl list of tomlish tokens + + set s [join $args \n] + + namespace upvar ::tomlish::parse is_parsing is_parsing + set is_parsing 1 + + if {[info command ::tomlish::parse::spacestack] eq "::tomlish::parse::spacestack"} { + tomlish::parse::spacestack destroy + } + struct::stack ::tomlish::parse::spacestack + + namespace upvar ::tomlish::parse last_space_action last_space_action + namespace upvar ::tomlish::parse last_space_type last_space_type + + namespace upvar ::tomlish::parse tok tok + set tok "" + + namespace upvar ::tomlish::parse type type + namespace upvar ::tomlish::parse tokenType tokenType + ::tomlish::parse::set_tokenType "" + namespace upvar ::tomlish::parse tokenType_list tokenType_list + set tokenType [list] ;#Flat (un-nested) list of tokentypes found + + namespace upvar ::tomlish::parse lastChar lastChar + set lastChar "" + + + set result "" + namespace upvar ::tomlish::parse nest nest + set nest 0 + + namespace upvar ::tomlish::parse v v ;#array keyed on nest level + + + set v(0) {TOMLISH} + array set s0 [list] ;#whitespace data to go in {SPACE {}} element. + set parentlevel 0 + + namespace upvar ::tomlish::parse i i + set i 0 + + namespace upvar ::tomlish::parse state state + + namespace upvar ::tomlish::parse braceCount braceCount + set barceCount 0 + namespace upvar ::tomlish::parse bracketCount bracketCount + set bracketCount 0 + + set sep 0 + set r 1 + namespace upvar ::tomlish::parse token_waiting token_waiting + set token_waiting [dict create] ;#if ::tok finds a *complete* second token during a run, it will put the 2nd one here to be returned by the next call. + + + set state "table-space" + ::tomlish::parse::spacestack push {type space state table-space} + namespace upvar ::tomlish::parse linenum linenum;#'line number' of input data. (incremented for each literal linefeed - but not escaped ones in data) + set linenum 1 + + set ::tomlish::parse::state_list [list] + try { + while {$r} { + set r [::tomlish::parse::tok $s] + #puts stdout "got tok: '$tok' while parsing string '$s' " + set next_tokenType_known 0 ;#whether we begin a new token here based on what terminated the token result of 'tok' + + + #puts "got token: '$tok' tokenType='$tokenType'. while v($nest) = [set v($nest)]" + #puts "-->tok: $tok tokenType='$tokenType'" + set prevstate $state + set transition_info [::tomlish::parse::goNextState $tokenType $tok $state] + #review goNextState could perform more than one space_action + set space_action [dict get $transition_info space_action] + set newstate [dict get $transition_info newstate] ;#use of 'newstate' vs 'state' makes code clearer below + + if {[tcl::string::match "err-*" $state]} { + ::tomlish::log::warn "---- State error in state $prevstate for tokenType: $tokenType token value: $tok. $state aborting parse. [tomlish::parse::report_line]" + lappend v(0) [list ERROR tokentype $tokenType state $prevstate to $state leveldata [set v($nest)]] + return $v(0) + } + # --------------------------------------------------------- + #NOTE there may already be a token_waiting at this point + #set_token_waiting can raise an error here, + # in which case the space_action branch needs to be rewritten to handle the existing token_waiting + # --------------------------------------------------------- + + if {$space_action eq "pop"} { + #pop_trigger_tokens: newline tablename endarray endinlinetable + #note a token is a pop trigger depending on context. e.g first newline during keyval is a pop trigger. + set parentlevel [expr {$nest -1}] + set do_append_to_parent 1 ;#most tokens will leave this alone - but some like tentative_accum_squote need to do their own append + switch -exact -- $tokenType { + tentative_accum_squote { + #should only apply within a multiliteral + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the xxx-squote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-squote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-squote-space { + } + default { + error "--- unexpected popped due to tentative_accum_squote but came from state '$prevstate' should have been trailing-squote-space" + } + } + switch -- $tok { + ' { + tomlish::parse::set_token_waiting type single_squote value $tok complete 1 startindex [expr {$i -1}] + } + '' { + #review - we should perhaps return double_squote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_squote value "" complete 1 startindex [expr {$i - 2}] + } + ''' { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 3}] + } + '''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left squote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]'" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "'"] + } + MULTILITERAL { + #empty + lappend v($parentlevel) [list LITERALPART "'"] + } + default { + error "--- don't know how to integrate extra trailing squote with data $v($parentlevel)" + } + } + } + ''''' { + tomlish::parse::set_token_waiting type triple_squote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 squotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + LITERALPART { + set newval "[lindex $lastpart 1]''" + set parentdata $v($parentlevel) + lset parentdata end [list LITERALPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE { + lappend v($parentlevel) [list LITERALPART "''"] + } + MULTILITERAL { + lappend v($parentlevel) [list LITERALPART "''"] + } + default { + error "--- don't know how to integrate extra trailing 2 squotes with data $v($parentlevel)" + } + } + } + } + } + triple_squote { + #presumably popping multiliteral-space + ::tomlish::log::debug "---- triple_squote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTILITERAL { + lappend merged $part + } + LITERALPART { + if {$lasttype eq "LITERALPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_squote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + tentative_accum_dquote { + #should only apply within a multistring + #### + set do_append_to_parent 0 ;#mark false to indicate we will do our own appends if needed + #Without this - we would get extraneous empty list entries in the parent + # - as the trailing-dquote-space isn't a space level from the toml perspective + # - the use of a space is to give us a hook here to (possibly) integrate extra quotes into the parent space when we pop + #assert prevstate always trailing-dquote-space + #dev guardrail - remove? assertion lib? + switch -exact -- $prevstate { + trailing-dquote-space { + } + default { + error "--- unexpected popped due to tentative_accum_dquote but came from state '$prevstate' should have been trailing-dquote-space" + } + } + switch -- $tok { + {"} { + tomlish::parse::set_token_waiting type single_dquote value $tok complete 1 startindex [expr {$i -1}] + } + {""} { + #review - we should perhaps return double_dquote instead? + #tomlish::parse::set_token_waiting type literal value "" complete 1 + tomlish::parse::set_token_waiting type double_dquote value "" complete 1 startindex [expr {$i - 2}] + } + {"""} { + #### + #if already an eof in token_waiting - set_token_waiting will insert before it + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 3}] + } + {""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i - 4}] + #todo integrate left dquote with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {"}] + } + MULTISTRING { + #empty + lappend v($parentlevel) [list STRINGPART {"}] + } + default { + error "--- don't know how to integrate extra trailing dquote with data $v($parentlevel)" + } + } + } + {"""""} { + tomlish::parse::set_token_waiting type triple_dquote value $tok complete 1 startindex [expr {$i-5}] + #todo integrate left 2 dquotes with nest data at this level + set lastpart [lindex $v($parentlevel) end] + switch -- [lindex $lastpart 0] { + STRINGPART { + set newval "[lindex $lastpart 1]\"\"" + set parentdata $v($parentlevel) + lset parentdata end [list STRINGPART $newval] + set v($parentlevel) $parentdata + } + NEWLINE - CONT - WS { + lappend v($parentlevel) [list STRINGPART {""}] + } + MULTISTRING { + lappend v($parentlevel) [list STRINGPART {""}] + } + default { + error "--- don't know how to integrate extra trailing 2 dquotes with data $v($parentlevel)" + } + } + } + } + } + triple_dquote { + #presumably popping multistring-space + ::tomlish::log::debug "---- triple_dquote for last_space_action pop leveldata: $v($nest)" + set merged [list] + set lasttype "" + foreach part $v($nest) { + switch -exact -- [lindex $part 0] { + MULTISTRING { + lappend merged $part + } + STRINGPART { + if {$lasttype eq "STRINGPART"} { + set prevpart [lindex $merged end] + lset prevpart 1 [lindex $prevpart 1][lindex $part 1] + lset merged end $prevpart + } else { + lappend merged $part + } + } + CONT - WS { + lappend merged $part + } + NEWLINE { + #note that even though first newline ultimately gets stripped from multiliterals - that isn't done here + #we still need the first one for roundtripping. The datastructure stage is where it gets stripped. + lappend merged $part + } + default { + error "---- triple_dquote unhandled part type [lindex $part 0] unable to merge leveldata: $v($nest)" + } + } + set lasttype [lindex $part 0] + } + set v($nest) $merged + } + equal { + #pop caused by = + switch -exact -- $prevstate { + dottedkey-space { + tomlish::log::debug "---- equal ending dottedkey-space for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + dottedkey-space-tail { + #experiment? + tomlish::log::debug "---- equal ending dottedkey-space-tail for last_space_action pop" + #re-emit for parent space + tomlish::parse::set_token_waiting type equal value = complete 1 startindex [expr {$i-1}] + } + } + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + tablename { + #note: a tablename only 'pops' if we are greater than zero + error "---- tablename pop should already have been handled as special case zeropoppushspace in goNextState" + } + tablearrayname { + #!review - tablearrayname different to tablename regarding push/pop? + #note: a tablename only 'pops' if we are greater than zero + error "---- tablearrayname pop should already have been handled as special case zeropoppushspace in goNextState" + } + endarray { + #nothing to do here. + } + comma { + #comma for inline table will pop the keyvalue space + lappend v($nest) "SEP" + } + endinlinetable { + ::tomlish::log::debug "---- endinlinetable for last_space_action pop" + } + default { + error "---- unexpected tokenType '$tokenType' for last_space_action 'pop'" + } + } + if {$do_append_to_parent} { + #e.g tentative_accum_squote does it's own appends as necessary - so won't get here + lappend v($parentlevel) [set v($nest)] + } + + incr nest -1 + + } elseif {$last_space_action eq "push"} { + set prevnest $nest + incr nest 1 + set v($nest) [list] + # push_trigger_tokens: barekey dquotedkey startinlinetable startarray tablename tablearrayname + + + switch -exact -- $tokenType { + tentative_trigger_squote - tentative_trigger_dquote { + #### this startok will always be tentative_accum_squote/tentative_accum_dquote starting with one accumulated squote/dquote + if {[dict exists $transition_info starttok] && [dict get $transition_info starttok] ne ""} { + lassign [dict get $transition_info starttok] starttok_type starttok_val + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType $starttok_type + set tok $starttok_val + } + } + single_squote { + #JMN - REVIEW + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + triple_squote { + ::tomlish::log::debug "---- push trigger tokenType triple_squote" + set v($nest) [list MULTILITERAL] ;#container for NEWLINE,LITERALPART + } + squotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + triple_dquote { + set v($nest) [list MULTISTRING] ;#container for NEWLINE,STRINGPART,CONT + } + dquotedkey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + barekey { + switch -exact -- $prevstate { + table-space - itable-space { + set v($nest) [list DOTTEDKEY] + } + } + #todo - check not something already waiting? + set waiting [tomlish::parse::get_token_waiting] + if {[llength $waiting]} { + set i [dict get $waiting startindex] + tomlish::parse::clear_token_waiting + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } else { + tomlish::parse::set_token_waiting type $tokenType value $tok complete 1 startindex [expr {$i -[tcl::string::length $tok]}] ;#re-submit token in the newly pushed space + } + } + tablename { + #note: we do not use the output of tomlish::to_dict::tablename_trim to produce a tablename for storage in the tomlish list! + #The tomlish list is intended to preserve all whitespace (and comments) - so a roundtrip from toml file to tomlish + # back to toml file will be identical. + #It is up to the datastructure stage to normalize and interpret tomlish for programmatic access. + # we call tablename_trim here only to to validate that the tablename data is well-formed at the outermost level, + # so we can raise an error at this point rather than create a tomlish list with obviously invalid table names from + # a structural perspective. + + #todo - review! It's arguable that we should not do any validation here, and just store even incorrect raw tablenames, + # so that the tomlish list is more useful for say a toml editor. Consider adding an 'err' tag to the appropriate place in the + # tomlish list? + + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablename: '$trimtable'" + set v($nest) [list TABLE $tok] ;#$tok is the *raw* table name + #note also that equivalent tablenames may have different toml representations even after being trimmed! + #e.g ["x\t\t"] & ["x "] (tab escapes vs literals) + #These will show as above in the tomlish list, but should normalize to the same tablename when used as keys by the datastructure stage. + } + tablearrayname { + #set trimtable [::tomlish::to_dict::tablename_trim $tok] + #::tomlish::log::debug "---- trimmed (but not normalized) tablearrayname: '$trimtable'" + set v($nest) [list TABLEARRAY $tok] ;#$tok is the *raw* tablearray name + } + startarray { + set v($nest) [list ARRAY] ;#$tok is just the opening bracket - don't output. + } + startinlinetable { + set v($nest) [list ITABLE] ;#$tok is just the opening curly brace - don't output. + } + default { + error "---- push trigger tokenType '$tokenType' not yet implemented" + } + } + + } else { + #no space level change + switch -exact -- $tokenType { + squotedkey { + #puts "---- squotedkey in state $prevstate (no space level change)" + lappend v($nest) [list SQKEY $tok] + } + dquotedkey { + #puts "---- dquotedkey in state $prevstate (no space level change)" + lappend v($nest) [list DQKEY $tok] + } + barekey { + lappend v($nest) [list KEY $tok] + } + dotsep { + lappend v($nest) [list DOTSEP] + } + starttablename { + #$tok is triggered by the opening bracket and sends nothing to output + } + starttablearrayname { + #$tok is triggered by the double opening brackets and sends nothing to output + } + tablename - tablenamearray { + error "---- did not expect 'tablename/tablearrayname' without space level change (no space level change)" + #set v($nest) [list TABLE $tok] + } + endtablename - endtablearrayname { + #no output into the tomlish list for this token + } + startinlinetable { + puts stderr "---- decode::toml error. did not expect startinlinetable without space level change (no space level change)" + } + single_dquote { + switch -exact -- $newstate { + string-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "string" + set tok "" + } + dquoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "dquotedkey" + set tok "" + } + multistring-space { + lappend v($nest) [list STRINGPART {"}] + #may need to be joined on pop if there are neighbouring STRINGPARTS + } + default { + error "---- single_dquote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_dquote { + #leading extra quotes - test: toml_multistring_startquote2 + switch -exact -- $prevstate { + itable-keyval-value-expected - keyval-value-expected { + puts stderr "tomlish::decode::toml double_dquote TEST" + #empty string + lappend v($nest) [list STRINGPART ""] + } + multistring-space { + #multistring-space to multistring-space + lappend v($nest) [list STRINGPART {""}] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + + } + single_squote { + switch -exact -- $newstate { + literal-state { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "literal" + set tok "" + } + squoted-key { + set next_tokenType_known 1 + ::tomlish::parse::set_tokenType "squotedkey" + set tok "" + } + multiliteral-space { + #false alarm squote returned from tentative_accum_squote pop + ::tomlish::log::debug "---- adding lone squote to own LITERALPART nextstate: $newstate (no space level change)" + #(single squote - not terminating space) + lappend v($nest) [list LITERALPART '] + #may need to be joined on pop if there are neighbouring LITERALPARTs + } + default { + error "---- single_squote switch case not implemented for nextstate: $newstate (no space level change)" + } + } + } + double_squote { + switch -exact -- $prevstate { + keyval-value-expected { + lappend v($nest) [list LITERAL ""] + } + multiliteral-space { + #multiliteral-space to multiliteral-space + lappend v($nest) [list LITERALPART ''] + } + default { + error "--- unhandled tokenType '$tokenType' when transitioning from state $prevstate to $newstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + enddquote { + #nothing to do? + set tok "" + } + endsquote { + set tok "" + } + string { + lappend v($nest) [list STRING $tok] ;#directly wrapped in dquotes + } + literal { + lappend v($nest) [list LITERAL $tok] ;#directly wrapped in squotes + } + multistring { + #review + lappend v($nest) [list MULTISTRING $tok] + } + stringpart { + lappend v($nest) [list STRINGPART $tok] ;#will not get wrapped in dquotes directly + } + multiliteral { + lappend v($nest) [LIST MULTILITERAL $tok] + } + literalpart { + lappend v($nest) [list LITERALPART $tok] ;#will not get wrapped in squotes directly + } + untyped_value { + #would be better termed unclassified_value + #we can't determine the type of unquoted values (int,float,datetime,bool) until the entire token was read. + unset -nocomplain tag + if {$tok in {true false}} { + set tag BOOL + } else { + if {[::tomlish::utils::is_int $tok]} { + set tag INT + } else { + if {[string is integer -strict $tok]} { + #didn't qualify as a toml int - but still an int + #probably means is_int is limiting size and not accepting bigints (configurable?) + #or it didn't qualify due to more than 1 leading zero + #or other integer format issue such as repeated underscores + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. (looks close to being an int. Formatting or range issue?) [tomlish::parse::report_line] (no space level change)" + } else { + if {[::tomlish::utils::is_float $tok]} { + set tag FLOAT + } elseif {[::tomlish::utils::is_datetime $tok] || [::tomlish::utils::is_timepart $tok]} { + #Note we must allow lone timepart here (not just is_localtime which doesn't allow tz offsets) in case it followed a localdate + #e.g x= 2025-01-01 02:34Z + #The to_dict validation will catch an invalid standaline timepart, or combine with leading date if applicable. + set tag DATETIME + } else { + error "---- Unable to interpret '$tok' as Boolean, Integer, Float or Datetime as per the toml specs. [tomlish::parse::report_line] (no space level change)" + } + } + } + } + #assert either tag is set, or we errored out. + lappend v($nest) [list $tag $tok] + + } + comment { + #puts stdout "----- comment token returned '$tok'------" + lappend v($nest) [list COMMENT "$tok"] + } + equal { + #we append '=' to the nest so that any surrounding whitespace is retained. + lappend v($nest) = + } + comma { + lappend v($nest) SEP + } + newline { + incr linenum + lappend v($nest) [list NEWLINE $tok] + } + whitespace { + lappend v($nest) [list WS $tok] + } + continuation { + lappend v($nest) CONT + } + bom { + lappend v($nest) BOM + } + eof { + #ok - nothing more to add to the tomlish list. + #!todo - check previous tokens are complete/valid? + } + default { + error "--- unknown tokenType '$tokenType' during state $prevstate [::tomlish::parse::report_line] (no space level change)" + } + } + } + + if {!$next_tokenType_known} { + ::tomlish::log::notice "---- tomlish::decode::toml - current tokenType:$tokenType Next token type not known" + ::tomlish::parse::set_tokenType "" + set tok "" + } + + if {$state eq "end-state"} { + break + } + + + } + + #while {$nest > 0} { + # lappend v([expr {$nest -1}]) [set v($nest)] + # incr nest -1 + #} + while {[::tomlish::parse::spacestack size] > 1} { + ::tomlish::parse::spacestack pop + lappend v([expr {$nest -1}]) [set v($nest)] + incr nest -1 + + #set parent [spacestack peek] ;#the level being appended to + #lassign $parent type state + #if {$type eq "space"} { + # + #} elseif {$type eq "buffer"} { + # lappend v([expr {$nest -1}]) {*}[set v($nest)] + #} else { + # error "invalid spacestack item: $parent" + #} + } + + } finally { + set is_parsing 0 + } + return $v(0) + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::decode ---}] +} +#decode toml to tomlish +interp alias {} tomlish::from_toml {} tomlish::decode::toml + +namespace eval tomlish::utils { + #*** !doctools + #[subsection {Namespace tomlish::utils}] + #[para] + #[list_begin definitions] + + + + #basic generic quote matching for single and double quotes + #note for example that {[o'malley]} will return sq - as the single quote is not closed or wrapped in double quotes + proc tok_in_quotedpart {tok} { + set sLen [tcl::string::length $tok] + set quote_type "" + set had_slash 0 + for {set i 0} {$i < $sLen} {incr i} { + set c [tcl::string::index $tok $i] + if {$quote_type eq ""} { + if {$had_slash} { + #don't enter quote mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + set quote_type dq + } + sq { + set quote_type sq + } + bsl { + set had_slash 1 + } + } + } + } else { + if {$had_slash} { + #don't leave quoted mode + #leave slash_mode because even if current char is slash - it is escaped + set had_slash 0 + } else { + set ctype [tcl::string::map [list {"} dq {'} sq \\ bsl] $c] + switch -- $ctype { + dq { + if {$quote_type eq "dq"} { + set quote_type "" + } + } + sq { + if {$quote_type eq "sq"} { + set quote_type "" + } + } + bsl { + set had_slash 1 + } + } + } + } + } + return $quote_type ;#dq | sq + } + + + proc unicode_escape_info {slashu} { + #!todo + # validate that slashu is either a \uxxxx or \Uxxxxxxxx value of the correct length and + # is a valid 'unicode scalar value' (any Unicode code point except high-surrogate and low-surrogate code points) + # ie integers in the range 0 to D7FF16 and E00016 to 10FFFF16 inclusive + #expr {(($x >= 0) && ($x <= 0xD7FF16)) || (($x >= 0xE00016) && ($x <= 0x10FFFF16))} + if {[tcl::string::match {\\u*} $slashu]} { + set exp {^\\u([0-9a-fA-F]{4}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %4x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } + } else { + return [list err [list reason "Supplied string not of the form \\uHHHH where H in \[0-9a-fA-F\]"]] + } + } elseif {[tcl::string::match {\\U*} $slashu]} { + set exp {^\\U([0-9a-fA-F]{8}$)} + if {[regexp $exp $slashu match hex]} { + if {[scan $hex %8x dec] != 1} { + #why would a scan ever fail after matching the regexp? !todo - review. unreachable branch? + return [list err [list reason "Failed to convert '$hex' to decimal"]] + } else { + if {(($dec >= 0) && ($dec <= 0xD7FF16)) || (($dec >= 0xE00016) && ($dec <= 0x10FFFF16))} { + return [list ok [list char [subst -nocommand -novariable $slashu]]] + } else { + return [list err [list reason "$slashu is not within the 'unicode scalar value' ranges 0 to 0xD7FF16 or 0xE00016 to 0x10FFFF16"]] + } + } + } else { + return [list err [list reason "Supplied string not of the form \\UHHHHHHHH where H in \[0-9a-fA-F\]"]] + } + } else { + return [list err [list reason "Supplied string did not start with \\u or \\U" ]] + } + + } + + #Note that unicode characters don't *have* to be escaped. + #So if we provide a function named 'escape_string', the name implies the inverse of unescape_string which unescapes unicode \u \U values. + #- an inverse of unescape_string would encode all unicode chars unnecessarily. + #- as toml accepts a compact escape sequence for common chars such as tab,backspace,linefeed etc but also allows the full form \u009 etc + #- escape_string and unescape_string would not be reliably roundtrippable inverses anyway. + #REVIEW - provide it anyway? When would it be desirable to use? + + variable Bstring_control_map [dict create] + dict set Bstring_control_map \b {\b} + dict set Bstring_control_map \n {\n} + dict set Bstring_control_map \r {\r} + dict set Bstring_control_map \" {\"} + dict set Bstring_control_map \x1b {\e} ;#In spec it's included in the list of 'must be escaped', as well as the 'convenience' escapes - so we make it go both ways. + dict set Bstring_control_map \\ "\\\\" + + #\e for \x1b seems like it might be included - v1.1?? hard to find current state of where toml is going :/ + #for a Bstring (Basic string) tab is explicitly mentioned as not being one that must be escaped. + #8 = \b - already in list. + #built the remainder whilst checking for entries already hardcoded above -in case more are added to the hardcoded list + for {set cdec 0} {$cdec <= 7} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + for {set cdec [expr {0x0A}]} {$cdec <= 0x1F} {incr cdec} { + set hhhh [format %.4X $cdec] + set char [format %c $cdec] + if {![dict exists $Bstring_control_map $char]} { + dict set Bstring_control_map $char \\u$hhhh + } + } + # \u007F = 127 + dict set Bstring_control_map [format %c 127] \\u007F + + #Note the inclusion of backslash in the list of controls makes this non idempotent - subsequent runs would keep encoding the backslashes! + #escape only those chars that must be escaped in a Bstring (e.g not tab which can be literal or escaped) + #for example - can be used by from_dict to produce valid Bstring data for a tomlish record + proc rawstring_to_Bstring_with_escaped_controls {str} { + #for the well known chars that have compact escape sequences allowed by toml - we choose that form over the full \u form. + #we'll use a string map with an explicit list rather than algorithmic at runtime + # - the string map is probably more performant than splitting a string, especially if it's large + variable Bstring_control_map + return [string map $Bstring_control_map $str] + } + + #review - unescape what string? Bstring vs MLBstring? + #we should be specific in the function naming here + #used by to_dict - so part of validation? - REVIEW + proc unescape_string {str} { + #note we can't just use Tcl subst because: + # it also transforms \a (audible bell) and \v (vertical tab) which are not in the toml spec. + # it would strip out backslashes inappropriately: e.g "\j" becomes just j + # it recognizes other escapes which aren't approprite e.g \xhh and octal \nnn + # it replaces \ with a single whitespace (trailing backslash) + #This means we shouldn't use 'subst' on the whole string, but instead substitute only the toml-specified escapes (\r \n \b \t \f \\ \" \uhhhh & \Uhhhhhhhh + #plus \e for \x1b? + + set buffer "" + set buffer4 "" ;#buffer for 4 hex characters following a \u + set buffer8 "" ;#buffer for 8 hex characters following a \u + + set sLen [tcl::string::length $str] + + #we need to handle arbitrarily long sequences of backslashes. \\\\\ etc + set slash_active 0 + set unicode4_active 0 + set unicode8_active 0 + + ::tomlish::log::debug "unescape_string. got len [string length str] str $str" + + #!todo - check for invalid data in the form of a raw carriage return (decimal 13) without following linefeed? + set i 0 + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $str [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $str $i] + #::tomlish::log::debug "unescape_string. got char $c" ;#too much? + + #---------------------- + #as we are 'unescaping' - should we really be testing for existing values that should have been escaped? + #this test looks incomplete anyway REVIEW + scan $c %c n + if {($n <= 31) && ($n != 9) && ($n != 10) && ($n != 13)} { + #we don't expect unescaped unicode characters from 0000 to 001F - + #*except* for raw tab (which is whitespace) and newlines + error "unescape_string. Invalid data for a toml string. Unescaped control character (decimal $n) [::tomlish::utils::string_to_slashu $c]" + } + #---------------------- + + incr i ;#must incr here because we do'returns'inside the loop + if {$c eq "\\"} { + if {$slash_active} { + append buffer "\\" + set slash_active 0 + } elseif {$unicode4_active} { + error "unescape_string. unexpected case slash during unicode4 not yet handled" + } elseif {$unicode8_active} { + error "unescape_string. unexpected case slash during unicode8 not yet handled" + } else { + # don't output anything (yet) + set slash_active 1 + } + } else { + if {$unicode4_active} { + if {[tcl::string::length $buffer4] < 4} { + append buffer4 $c + } + if {[tcl::string::length $buffer4] == 4} { + #we have a \uHHHH to test + set unicode4_active 0 + set result [tomlish::utils::unicode_escape_info "\\u$buffer4"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$unicode8_active} { + if {[tcl::string::length $buffer8] < 8} { + append buffer8 $c + } + if {[tcl::string::length $buffer8] == 8} { + #we have a \UHHHHHHHH to test + set unicode8_active 0 + set result [tomlish::utils::unicode_escape_info "\\U$buffer8"] + if {[lindex $result 0] eq "ok"} { + append buffer [dict get $result ok char] + } else { + error "unescape_string error: [lindex $result 1]" + } + } + } elseif {$slash_active} { + set slash_active 0 + set ctest [tcl::string::map {{"} dq} $c] + switch -exact -- $ctest { + dq { + append buffer {"} + } + b - t - n - f - r { + append buffer [subst -nocommand -novariable "\\$c"] + } + e { + append buffer \x1b + } + u { + set unicode4_active 1 + set buffer4 "" + } + U { + set unicode8_active 1 + set buffer8 "" + } + default { + set slash_active 0 + #review - toml spec says all other escapes are reserved + #and if they are used TOML should produce an error. + #we leave detecting this for caller for now - REVIEW + append buffer "\\$c" + } + } + } else { + append buffer $c + } + } + } + #puts stdout "EOF 4:$unicode4_active 8:$unicode8_active slash:$slash_active" + if {$unicode4_active} { + error "End of string reached before complete unicode escape sequence \uHHHH" + } + if {$unicode8_active} { + error "End of string reached before complete unicode escape sequence \UHHHHHHHH" + } + if {$slash_active} { + append buffer "\\" + } + return $buffer + } + + #This does not have to do with unicode normal forms - which it seems toml has decided against regarding use in keys (review/references?) + #This is meant for internal use regarding ensuring we match equivalent keys which may have just been specified with different string mechanisms, + #e.g squoted vs dquoted vs barekey. + proc normalize_key {rawkey} { + set c1 [tcl::string::index $rawkey 0] + set c2 [tcl::string::index $rawkey end] + if {($c1 eq "'") && ($c2 eq "'")} { + #single quoted segment. No escapes allowed within it. + set key [tcl::string::range $rawkey 1 end-1] + } elseif {($c1 eq "\"") && ($c2 eq "\"")} { + #double quoted segment. Apply escapes. + # + set keydata [tcl::string::range $rawkey 1 end-1] ;#strip outer quotes only + #e.g key could have mix of \UXXXXXXXX escapes and unicode chars + #or mix of \t and literal tabs. + #unescape to convert all to literal versions for comparison + set key [::tomlish::utils::unescape_string $keydata] + #set key [subst -nocommands -novariables $keydata] ;#wrong. Todo - create a string escape substitution function. + } else { + set key $rawkey + } + return $key + } + + proc string_to_slashu {string} { + set rv {} + foreach c [split $string {}] { + scan $c %c cdec + if {$cdec > 65535} { + append rv {\U} [format %.8X $cdec] + } else { + append rv {\u} [format %.4X $cdec] + } + } + return $rv + } + + #'nonprintable' is conservative here because some systems (e.g windows console) are very limited in what they can display. + #This is used for display purposes only (error msgs) + proc nonprintable_to_slashu {s} { + set res "" + foreach i [split $s ""] { + scan $i %c cdec + + set printable 0 + if {($cdec>31) && ($cdec<127)} { + set printable 1 + } + if {$printable} { + append res $i + } else { + if {$cdec > 65535} { + append res \\U[format %.8X $cdec] + } else { + append res \\u[format %.4X $cdec] + } + } + } + set res + } ;# initial version from tcl wiki RS + + #check if str is valid for use as a toml bare key + #Early toml versions? only allowed letters + underscore + dash + proc is_barekey1 {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } else { + set matches [regexp -all {[a-zA-Z0-9\_\-]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters match the regexp + return 1 + } else { + return 0 + } + } + } + + #from toml.abnf in github.com/toml-lang/toml + #unquoted-key = 1*unquoted-key-char + #unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _ + #unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions + #unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block + #unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon + #unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + #unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics + #unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + #unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators + #unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols + #unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation + #unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank + #unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space + #unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + #unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + variable re_barekey + set ranges [list] + lappend ranges {a-zA-Z0-9\_\-} + lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions + lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block + lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon + lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ + lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics + lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces + lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators + lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols + lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation + lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank + lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space + lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode) + lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF) + set re_barekey {^[} + foreach r $ranges { + append re_barekey $r + } + append re_barekey {]+$} + + proc is_barekey {str} { + if {[tcl::string::length $str] == 0} { + return 0 + } + variable re_barekey + return [regexp $re_barekey $str] + } + + #test only that the characters in str are valid for the toml specified type 'integer'. + proc int_validchars1 {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_\-\+]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + #add support for hex,octal,binary 0x.. 0o.. 0b... + proc int_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_int {str} { + set matches [regexp -all {[0-9\_xo\-\+A-Fa-f]} $str] ;#0b101 etc covered by a-f + + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + + # --------------------------------------- + #check for leading zeroes in non 0x 0b 0o + #first strip any +, - or _ (just for this test) + #(but still allowing 0 -0 +0) + set check [tcl::string::map {+ "" - "" _ ""} $str] + if {([tcl::string::length $check] > 1) && ([tcl::string::index $check 0] eq "0") && ([tcl::string::index $check 1] ni {o x b})} { + return 0 + } + # --------------------------------------- + + #check +,- only occur in the first position. (excludes also +++1 etc) + if {[tcl::string::last - $str] > 0} { + return 0 + } + if {[tcl::string::last + $str] > 0} { + return 0 + } + + #------------------------------------------- + #unclear if a 'digit' includes the type specifiers x b o + #we assume the 0x 0b 0o are NOT counted as digits - as underscores here would seem + #to be likely to cause interop issues with other systems + #(e.g tcl allows 0b1_1 but not 0b_11) + #Most of this structure would be unnecessary if we could rely on string::is::integer understanding underscores (9+?) + #we still need to support earlier Tcl for now though. + + #first rule out any case with more than one underscore in a row + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_0xFF + if {[string index $utest 0] eq "_"} { + return 0 + } + if {[string range $utest 0 1] in {0x 0b 0o}} { + set testnum [string range $utest 2 end] + } else { + set testnum $utest + #exclude also things like 0_x 0___b that snuck past our prefix test + if {![string is digit -strict [string map {_ ""} $testnum]]} { + return 0 + } + #assert - only digits and underscores in testnum + #still may have underscores at each end + } + #assert testnum is now the 'digits' portion of a , 0x 0b 0o number + #(+ and - already stripped) + #It may still have chars unsuitable for its type - which will be caught by the string::is::integer test below + if {[string length $testnum] != [string length [string trim $testnum _]]} { + #had non-inner underscores in 'digit' part + return 0 + } + #assert str only has solo inner underscores (if any) between 'digits' + #------------------------------------------- + + set numeric_value [tcl::string::map {_ ""} $str] ;#allow some earlier tcl versions which don't support underscores + #use Tcl's integer check to ensure we don't let things like 3e4 through - which is a float (would need to be 0x3e4 for hex) + if {![tcl::string::is integer -strict $numeric_value]} { + return 0 + } + + + + #!todo - check bounds only based on some config value + #even though Tcl can handle bignums, we won't accept anything outside of toml 1.0 minimum requirements by default (for now) + #presumably very large numbers would have to be supplied in a toml file as strings. + #Review - toml 1.0 only says that it must handle up to 2^63 - not that this is a max + #some question around implementations allowed to use lower values such as 2^31 on some systems? + if {$::tomlish::max_int ne "" && $numeric_value > $::tomlish::max_int} { + return 0 + } + if {$::tomlish::min_int ne "" && $numeric_value < $::tomlish::min_int} { + return 0 + } + } else { + return 0 + } + #Got this far - didn't find anything wrong with it. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'float'. + proc float_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[eE0-9\_\-\+\.]} $str] == $numchars} { + return 1 + } else { + #only allow lower case for these special values - as per Toml 1.0 spec + if {$str ni {inf +inf -inf nan +nan -nan}} { + return 0 + } else { + return 1 + } + } + } + + #note - Tcl's string is double will return true also for the subset of float values which are integers + #This function is to determine whether it matches the Toml float concept - so requires a . or e or E + proc is_float {str} { + #vip greenlight known literals, don't test for case variations - as Toml doesn't allow (whereas Tcl allows Inf NaN etc) + if {$str in {inf +inf -inf nan +nan -nan}} { + return 1 + } + #doorcheck the basics for floatiness vs members of that rival gang - ints + if {![regexp {[.eE]} $str]} { + #could be an integer - which isn't specifically a float for Toml purposes. + return 0 + } + + + #patdown for any contraband chars + set matches [regexp -all {[eE0-9\_\-\+\.]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + + #all characters in legal range + + #A leading zero is ok, but we should disallow multiple leading zeroes (same rules as toml ints) + + #Early Toml spec also disallowed leading zeros in the exponent part(?) + #... this seems less interoperable anyway (some libraries generate leading zeroes in exponents) + #we allow leading zeros in exponents here. + + #Check for leading zeros in main part + #first strip any +, - or _ (just for this test) + set check [tcl::string::map {+ "" - "" _ ""} $str] + set r {([0-9])*} + regexp $r $check intpart ;#intpart holds all numerals before the first .,e or E + set z {([0])*} + regexp $z $intpart leadingzeros + if {[tcl::string::length $leadingzeros] > 1} { + return 0 + } + + #for floats, +,- may occur in multiple places + #e.g -2E-22 +3e34 + #!todo - check bounds ? + + #----------------------------------------- + if {[regexp {__} $str]} { + return 0 + } + if {[string index $str 0] eq "_" || [string index $str end] eq "_"} { + return 0 + } + set utest [string trimleft $str +-] + #test again for further trick like _+_ + if {[string index $utest 0] eq "_"} { + return 0 + } + #----------------------------------------- + + #decimal point, if used must be surrounded by at least one digit on each side + #e.g 3.e+20 also illegal + set dposn [string first . $str] + if {$dposn > -1 } { + set d3 [string range $str $dposn-1 $dposn+1] + if {![string is integer -strict [string index $d3 0]] || ![string is integer -strict [string index $d3 2]]} { + return 0 + } + } + #we've already eliminated leading/trailing underscores + #now ensure each inner underscore is surrounded by digits + if {[regexp {_[^0-9]|[^0-9]_} $str]} { + return 0 + } + + #strip underscores for tcl double check so we can support < tcl 9 versions which didn't allow underscores + set check [tcl::string::map {_ ""} $str] + #string is double accepts inf nan +NaN etc. + if {![tcl::string::is double $check]} { + return 0 + } + + #All good - seems to be a toml-approved float and not an int. + return 1 + } + + #test only that the characters in str are valid for the toml specified type 'datetime'. + proc datetime_validchars {str} { + set numchars [tcl::string::length $str] + if {[regexp -all {[zZtT0-9\-\+\.:]} $str] == $numchars} { + return 1 + } else { + return 0 + } + } + + proc is_datepart {str} { + set matches [regexp -all {[0-9\-]} $str] + if {[tcl::string::length $str] != $matches} { + return 0 + } + #seems to require yyyy-mm-dd (e.g not allowing just yyyy-mm) + if {![regexp {^([0-9]{4})-([0-9]{2})-([0-9]{2})$} $str _match y m d]} { + return 0 + } + if {$m > 12 || $m == 0} { + return 0 + } + switch -- [expr {$m}] { + 1 - 3 - 5 - 7 - 8 - 10 - 12 { + if {$d > 31 || $d == 0} { + return 0 + } + } + 2 { + if {$d > 29 || $d == 0} { + return 0 + } + if {$d == 29} { + #leapyear check + if {[catch {clock scan $str -format %Y-%m-%d} errM]} { + return 0 + } + } + } + 4 - 6 - 9 - 11 { + if {$d > 30 || $d == 0} { + return 0 + } + } + } + return 1 + } + proc is_localdate {str} { + is_datepart $str + } + proc is_timepart {str} { + set numchars [tcl::string::length $str] + #timepart can have negative or positive offsets so - and + must be accepted + if {[regexp -all {[zZt0-9\-\+\.:]} $str] == $numchars} { + #todo + #basic check that we have leading 2dig hr and 2dig min separated by colon + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}[^0-9]{1}.*$} $str]} { + #nn:nn or nn:nnX.* where X is non digit + return 0 + } + return 1 + } else { + return 0 + } + } + proc is_localtime {str} { + #time of day without any relation to a specific day or any offset or timezone + set numchars [tcl::string::length $str] + if {[regexp -all {[0-9\.:]} $str] == $numchars} { + #todo + if {![regexp {^[0-9]{2}:[0-9]{2}$|^[0-9]{2}:[0-9]{2}:[0-9]{2}([.][0-9]*){0,1}$} $str]} { + #hh:mm or hh:mm:ss or hh:mm::ss.nnn + return 0 + } + return 1 + } else { + return 0 + } + } + + #review + proc is_datetime {str} { + #Essentially RFC3339 formatted date-time - but: + #1) allowing seconds to be omitted (:00 assumed) + #2) T may be replaced with a single space character TODO - parser support for space in datetime! + # (RFC 3339 allows space instead of T also - but doesn't specify it *must* be a single space) + + #toml-lint @2025-04 doesn't accept t for T or z for Z - but RFC3339 does + #toml spec doesn't clarify - we will accept + + #e.g 1979-05-27 + #e.g 1979-05-27T00:32:00Z + #e.g 1979-05-27 00:32:00-07:00 + #e.g 1979-05-27 00:32:00+10:00 + #e.g 1979-05-27 00:32:00.999999-07:00 + + #review + #minimal datetimes? + # 2024 not ok - 2024T not accepted by tomlint why? + # 02:00 ok + # 02:00:00.5 ok + # 1:00 - not ok - RFC3339 requires 2-digit hr,min,sec + + #toml-lint.com accepts 2025-01 + + if {[string length $str] < 5} { + return 0 + } + + set matches [regexp -all {[zZtT0-9\ \-\+\.:]} $str] + if {[tcl::string::length $str] == $matches} { + #all characters in legal range + if {[regexp -all {\ } $str] > 1} { + #only a single space is allowed. + return 0 + } + #If we get a space - it is only valid as a convience to represent the T separator + #we can normalize by converting to T here before more tests + set str [string map {" " T t T} $str] + #a further sanity check on T + if {[regexp -all {T} $str] > 1} { + return 0 + } + + #!todo - use full RFC 3339 parser? + #!todo - what if the value is 'time only'? + + if {[string first T $str] > -1} { + lassign [split $str T] datepart timepart + if {![is_datepart $datepart]} { + return 0 + } + if {![is_timepart $timepart]} { + return 0 + } + } else { + #either a datepart or a localtime + #spec: "If you include only the time portion of an RFC 3339 formatted date-time, it will represent that time of day + # without any relation to a specific day or any offset or timezone." + if {!([is_datepart $str] || [is_localtime $str])} { + return 0 + } + } + + + #Tcl's free-form clock scan (no -format option) is deprecated + # + #if {[catch {clock scan $datepart} err]} { + # puts stderr "tcl clock scan failed err:'$err'" + # return 0 + #} + + } else { + return 0 + } + return 1 + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::utils ---}] +} + +namespace eval tomlish::parse { + #*** !doctools + #[subsection {Namespace tomlish::parse}] + #[para] + #[list_begin definitions] + + #This is a somewhat curly mix of a statemachine and toml-nesting-stack littered with special cases. + #The code is a pig's-nest - but it should be noted that for example trailing single double quotes in multiline strings are perhaps not so trivial to parse using more standard methods either: + # - e.g some kind of backtracking required if using an ABNF parser? + #I don't know the precise technical name for this sort of parser; probably something like "Dog's Breakfast" + #More seriously, we don't have distinct lex/parse steps - so it is basically a 'fused lexer' or 'scannerless parser' + + #It is also desirable for this system to be useful in 'interactive' use. review - would a separate lexer make this easier or harder? + + #A possible alternative more structured approach might be to use a PEG (Parsing Expression Grammar) + + + variable is_parsing 0 ;#whether we are in the middle of parsing tomlish text + + variable state + # states: + # table-space, itable-space, array-space + # array-value-expected,keyval-value-expected,itable-keyval-value-expected, keyval-syntax, + # dquoted-key, squoted-key + # string-state, literal-state, multistring... + # + # notes: + # only the -space states are also 'spaces' ie a container which is pushed/popped on the spacestack + + # + # xxx_value-expected - we also allow for leading whitespace in this state, but once a value is returned we jump to a state based on the containing space. e.g keyval-tail or array-syntax + # + #stateMatrix defines for each state, actions to take for each possible token. + #single-element actions are the name of the next state into which to transition, or a 'POPSPACE' instruction to pop a level off the spacestack and add the data to the parent container. + #dual-element actions are a push instruction and the name of the space to push on the stack. + # - PUSHSPACE is a simple push onto the spacestack, zeropoppushspace also pushes, but will first do a pop *if* the current space level is greater than zero (ie if only if not already in root table-space) + + # -- --- --- --- --- --- + #token/state naming guide + # -- --- --- --- --- --- + #tokens : underscore separated or bare name e.g newline, start_quote, start_squote + #private tokens: always have a leading underscore (These are private 'temporary state' tokens that are never returned as actual tokens e.g _start_squote_sequence + #states : always contain at least one dash e.g err-state, table-space + #instructions + # -- --- --- --- --- --- + + + #stateMatrix dict of elements mapping current state to next state based on returned tokens + # current-state {token-encountered next-state ... } + # where next-state can be a 1 or 2 element list. + #If 2 element - the first item is an instruction (ucase) + #If 1 element - it is either a lowercase dashed state name or an ucase instruction + #e.g {PUSHSPACE } or POPSPACE or SAMESPACE + + + #SAMESPACE - got to same space as parent without popping a level, but has it's own autotransition lookup - strange concept - review usecases + + variable stateMatrix + set stateMatrix [dict create] + #--------------------------------------------------------- + #WARNING + #The stateMatrix implementation here is currently messy. + #The code is a mixture of declarative via the stateMatrix and imperative via switch statements during PUSH/POP/SAMESPACE transitions. + #This means the state behaviour has to be reasoned about by looking at both in conjuction. + #--------------------------------------------------------- + + #xxx-space vs xxx-syntax inadequately documented - TODO + + #review - out of date? + # --------------------------------------------------------------------------------------------------------------# + # incomplete example of some state starting at table-space + # --------------------------------------------------------------------------------------------------------------# + # ( = -> keyval-value-expected) + # keyval-syntax (popped -> keyval-space -> keyval-tail) (autotransition on pop) + # keyval-space (autotransition on push ^) + # table-space (barekey^) (startdquote -> dquoted-key ^) + # --------------------------------------------------------------------------------------------------------------# + + dict set stateMatrix\ + table-space { + bom "table-space"\ + whitespace "table-space"\ + newline "table-space"\ + barekey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + squotedkey {PUSHSPACE "keyval-space" state "keyval-syntax" note ""}\ + dquotedkey {PUSHSPACE "keyval-space" state "keyval-syntax"}\ + XXXsingle_dquote "quoted-key"\ + XXXsingle_squote "squoted-key"\ + comment "table-space"\ + starttablename "tablename-state"\ + starttablearrayname "tablearrayname-state"\ + enddquote "err-state"\ + endsquote "err-state"\ + comma "err-state"\ + eof "end-state"\ + equal "err-state"\ + cr "err-lonecr"\ + } + + + + dict set stateMatrix\ + keyval-space {\ + whitespace "keyval-syntax"\ + equal "keyval-value-expected"\ + } + + # ' = ' portion of keyval + dict set stateMatrix\ + keyval-syntax {\ + whitespace "keyval-syntax"\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal "keyval-value-expected"\ + comma "err-state"\ + newline "err-state"\ + eof "err-state"\ + } + #### + dict set stateMatrix\ + keyval-value-expected {\ + whitespace "keyval-value-expected"\ + untyped_value {TOSTATE "keyval-untyped-sequence" note "possible datetime datepart"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + } + #double_squote {TOSTATE "keyval-tail" note "empty literal received when double squote occurs"} + + #untyped_value sequences without intervening comma are allowed for datepart timepart + #we will produce tomlish with missing SEPS and to_dict must validate whether 2 adjacent barekeys are valid + dict set stateMatrix\ + keyval-untyped-sequence {\ + whitespace "keyval-untyped-sequence"\ + untyped_value {TOSTATE "keyval-tail"}\ + literal {TOSTATE "keyval-tail" note "required for empty literal at EOF"}\ + string {TOSTATE "keyval-tail" note "required for empty string at EOF"}\ + single_dquote {TOSTATE "string-state" returnstate keyval-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate keyval-tail}\ + single_squote {TOSTATE "literal-state" returnstate keyval-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate keyval-tail}\ + startinlinetable {PUSHSPACE itable-space returnstate keyval-tail}\ + startarray {PUSHSPACE array-space returnstate keyval-tail}\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + #2025 - no leading-squote-space - only trailing-squote-space. + + dict set stateMatrix\ + keyval-tail {\ + whitespace "keyval-tail"\ + newline "POPSPACE"\ + comment "keyval-tail"\ + eof "end-state"\ + } + + + #itable-space/ curly-syntax : itables + # x={y=1,} + dict set stateMatrix\ + itable-space {\ + whitespace "itable-space"\ + newline "itable-space"\ + barekey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + squotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + dquotedkey {PUSHSPACE "itable-keyval-space" state "itable-keyval-syntax"}\ + endinlinetable "POPSPACE"\ + comma "err-state"\ + comment "itable-space"\ + eof "err-state"\ + } + #we don't get single_squote etc here - instead we get the resulting squotedkey token + + + # ??? review - something like this + # + # x={y =1,} + dict set stateMatrix\ + itable-keyval-syntax {\ + whitespace {TOSTATE "itable-keyval-syntax"}\ + barekey {PUSHSPACE "dottedkey-space"}\ + squotedkey {PUSHSPACE "dottedkey-space"}\ + dquotedkey {PUSHSPACE "dottedkey-space"}\ + equal {TOSTATE "itable-keyval-value-expected"}\ + newline "err-state"\ + eof "err-state"\ + } + + # x={y=1} + dict set stateMatrix\ + itable-keyval-space {\ + whitespace "itable-keyval-syntax"\ + equal {TOSTATE "itable-keyval-value-expected" note "required"}\ + } + + dict set stateMatrix\ + itable-keyval-value-expected {\ + whitespace "itable-keyval-value-expected"\ + untyped_value {TOSTATE "itable-val-tail" note ""}\ + single_dquote {TOSTATE "string-state" returnstate itable-val-tail}\ + triple_dquote {PUSHSPACE "multistring-space" returnstate itable-val-tail}\ + single_squote {TOSTATE "literal-state" returnstate itable-val-tail note "usual way a literal is triggered"}\ + triple_squote {PUSHSPACE "multiliteral-space" returnstate itable-val-tail}\ + startinlinetable {PUSHSPACE "itable-space" returnstate itable-val-tail}\ + startarray {PUSHSPACE "array-space" returnstate itable-val-tail}\ + } + #double_squote not currently generated by _start_squote_sequence - '' processed as single_squote to literal-state just like 'xxx' + # review + # double_squote {TOSTATE "itable-val-tail" note "empty literal received when double squote occurs"} + + + + # x={y=1,z="x"} + #POPSPACE is transition from itable-keyval-space to parent itable-space + dict set stateMatrix\ + itable-val-tail {\ + whitespace "itable-val-tail"\ + endinlinetable "POPSPACE"\ + comma "POPSPACE"\ + newline {TOSTATE "itable-val-tail" note "itable-space ??"}\ + comment "itable-val-tail"\ + eof "err-state"\ + } + # XXXnewline "POPSPACE" + # We shouldn't popspace on newline - as if there was no comma we need to stay in itable-val-tail + # This means the newline and subsequent whitespace, comments etc become part of the preceeding dottedkey record + #e.g + # x = { + # j=1 + # #comment within dottedkey j record + # , # comment unattached + # #comment unattached + # k=2 , #comment unattached + # l=3 #comment within l record + # , m=4 + # #comment associated with m record + # + # #still associated with m record + # } + ## - This doesn't quite correspond to what a user might expect - but seems like a consistent mechanism. + #The awkwardness is because there is no way to put in a comment that doesn't consume a trailing comma + #so we cant do: j= 1 #comment for j1 , + # and have the trailing comma recognised. + # + # To associate: j= 1, #comment for j1 + # we would need some extra processing . (not popping until next key ? extra state itable-sep-tail?) REVIEW - worth doing? + # + # The same issue occurs with multiline arrays. The most natural assumption is that a comment on same line after a comma + # is 'associated' with the previous entry. + # + # These comment issues are independent of the data dictionary being generated for conversion to json etc - as the comments don't carry through anyway, + # but are a potential oddity for manipulating the intermediate tomlish structure whilst attempting to preserve 'associated' comments + # (e.g reordering records within an itable) + #The user's intention for 'associated' isn't always clear and the specs don't really guide on this. + + + #dottedkey-space is not (currently) used within [tablename] or [[tablearrayname]] + #it is for keyval ie x.y.z = value + + #this is the state after dot + #we are expecting a complete key token or whitespace + #(initial entry to the space is by one of the keys - which will immediately go to dottedkey-space-tail) + dict set stateMatrix\ + dottedkey-space {\ + whitespace "dottedkey-space"\ + dotsep "err-state"\ + barekey "dottedkey-space-tail"\ + squotedkey "dottedkey-space-tail"\ + dquotedkey "dottedkey-space-tail"\ + newline "err-state"\ + comma "err-state"\ + comment "err-state"\ + equal "err-state"\ + } + + #dottedkeyend "POPSPACE" + #equal "POPSPACE"\ + + + #jmn 2025 + #we have 1 or more dottedkeys so far - need dotsep to add more, whitespace to maintain, equal to pop + dict set stateMatrix\ + dottedkey-space-tail {\ + whitespace "dottedkey-space-tail" + dotsep "dottedkey-space" + equal "POPSPACE"\ + eof "err-state"\ + newline "err-state"\ + } + + #-------------------------------------------------------------------------- + #scratch area + #from_toml {x=1} + # barekey tok + # table-space PUSHSPACE keyval-space state keyval-syntax + # + + + #-------------------------------------------------------------------------- + + + #REVIEW + #toml spec looks like heading towards allowing newlines within inline tables + #https://github.com/toml-lang/toml/issues/781 + + #2025 - multiline itables appear to be valid for 1.1 - which we are targeting. + #https://github.com/toml-lang/toml/blob/main/toml.md#inline-table + + #JMN2025 + #review comment "err-state" vs comment "itable-space" - see if TOML 1.1 comes out and allows comments in multiline ITABLES + #We currently allow multiline ITABLES (also with comments) in the tokenizer. + #if we want to disallow as per TOML 1.0 - we should do so when attempting to get structure? + + + #JMN REVIEW + #dict set stateMatrix\ + # array-space {\ + # whitespace "array-space"\ + # newline "array-space"\ + # untyped_value "SAMESPACE"\ + # startarray {PUSHSPACE "array-space"}\ + # endarray "POPSPACE"\ + # startinlinetable {PUSHSPACE itable-space}\ + # single_dquote "string-state"\ + # single_squote "literal-state"\ + # triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax note "seems ok 2024"}\ + # comma "array-space"\ + # comment "array-space"\ + # eof "err-state-array-space-got-eof"\ + # } + + ## array-space ## + set aspace [dict create] + dict set aspace whitespace "array-space" + dict set aspace newline "array-space" + #dict set aspace untyped_value "SAMESPACE" + dict set aspace untyped_value "array-syntax" + dict set aspace startarray {PUSHSPACE "array-space"} + dict set aspace endarray "POPSPACE" + dict set aspace single_dquote {TOSTATE "string-state" returnstate array-syntax} + dict set aspace triple_dquote {PUSHSPACE "multistring-space" returnstate array-syntax} + dict set aspace single_squote {TOSTATE "literal-state" returnstate array-syntax} + dict set aspace triple_squote {PUSHSPACE "multiliteral-space" returnstate array-syntax} + dict set aspace startinlinetable {PUSHSPACE itable-space} + #dict set aspace comma "array-space" + dict set aspace comment "array-space" + dict set aspace eof "err-state-array-space-got-eof" + dict set stateMatrix array-space $aspace + + #when we pop from an inner array we get to array-syntax + #e.g {x=[[]] ??? + set tarntail [dict create] + dict set tarntail whitespace "tablearrayname-tail" + dict set tarntail newline "err-state" + dict set tarntail comment "err-state" + dict set tarntail eof "err-state" + dict set tarntail endtablename "tablearray-tail" + dict set stateMatrix tablearrayname-tail $tarntail + + #review - somewhat counterintuitive...? + # [(starttablearrayname) (endtablearrayname] + # [(starttablename) (endtablename)] + + # [[xxx]] ??? + set tartail [dict create] + dict set tartail whitespace "tablearray-tail" + dict set tartail newline "table-space" + dict set tartail comment "tablearray-tail" + dict set tartail eof "end-state" + dict set stateMatrix tablearray-tail $tartail + + + + + + + dict set stateMatrix\ + end-state {} + + set knowntokens [list] + set knownstates [list] + dict for {state transitions} $stateMatrix { + if {$state ni $knownstates} {lappend knownstates $state} + dict for {tok instructions} $transitions { + if {$tok ni $knowntokens} {lappend knowntokens $tok} + } + } + dict set stateMatrix nostate {} + foreach tok $knowntokens { + dict set stateMatrix nostate $tok "err-nostate-received-token-$tok" + } + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #purpose - debugging? remove? + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #build a list of 'push triggers' from the stateMatrix + # ie tokens which can push a new space onto spacestack + set push_trigger_tokens [list] + tcl::dict::for {s transitions} $stateMatrix { + tcl::dict::for {token transition_to} $transitions { + set instruction [lindex $transition_to 0] + switch -exact -- $instruction { + PUSHSPACE - zeropoppushspace { + if {$token ni $push_trigger_tokens} { + lappend push_trigger_tokens $token + } + } + } + } + } + ::tomlish::log::debug "push_trigger_tokens: $push_trigger_tokens" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + + #This seems hacky... (deprecate in favour of explicit arguments to the instructions in stateMatrix?) + #spacePopTransitions, spacePushTransitions, spaceSameTransitions below for auto state redirections on POPSPACE,PUSHSPACE,SAMESPACE + + #mainly for the -space states: + #redirect to another state $c based on a state transition from $whatever to $b + # e.g "string {array-space array-syntax}" means when transitioning from string to array-space, jump to array-syntax instead. + #this is useful as we often don't know state $b. e.g when it is decided by 'POPSPACE' + + #use dict set to add values so we can easily add/remove/comment lines + + #Push to, next + #default first states when we push to these spaces + variable spacePushTransitions [dict create] + dict set spacePushTransitions keyval-space keyval-syntax + dict set spacePushTransitions itable-keyval-space itable-keyval-syntax + dict set spacePushTransitions array-space array-space + dict set spacePushTransitions table-space tablename-state + #dict set spacePushTransitions #itable-space itable-space + + #Pop to, next + variable spacePopTransitions [dict create] + dict set spacePopTransitions array-space array-syntax + + + #itable-keyval-space itable-val-tail + #review + #we pop to keyval-space from dottedkey-space or from keyval-value-expected? we don't always want to go to keyval-tail + #leave it out and make the POPSPACE caller explicitly specify it + #keyval-space keyval-tail + + variable spaceSameTransitions [dict create] + #JMN test + #dict set spaceSameTransitions array-space array-syntax + + #itable-keyval-space itable-val-tail + + + variable state_list ;#reset every tomlish::decode::toml + + namespace export tomlish toml + namespace ensemble create + + #goNextState has various side-effects e.g pushes and pops spacestack + #REVIEW - setting nest and v elements here is ugly + #todo - make neater, more single-purpose? + proc goNextState {tokentype tok currentstate} { + variable state + variable nest + variable v + + set prevstate $currentstate + + + variable spacePopTransitions + variable spacePushTransitions + variable spaceSameTransitions + + variable last_space_action "none" + variable last_space_type "none" + variable state_list + + set result "" + set starttok "" + + if {[dict exists $::tomlish::parse::stateMatrix $currentstate $tokentype]} { + set transition_to [dict get $::tomlish::parse::stateMatrix $currentstate $tokentype] + ::tomlish::log::debug "--->> goNextState tokentype:$tokentype tok:$tok currentstate:$currentstate : transition_to = $transition_to" + switch -exact -- [lindex $transition_to 0] { + POPSPACE { + set popfromspace_info [spacestack peek] + set popfromspace_state [dict get $popfromspace_info state] + spacestack pop + set parent_info [spacestack peek] + set type [dict get $parent_info type] + set parentspace [dict get $parent_info state] + + set last_space_action "pop" + set last_space_type $type + + if {[dict exists $parent_info returnstate]} { + set next [dict get $parent_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected to stored returnstate $next <<---" + } else { + ### + #review - do away with spacePopTransitions - which although useful to provide a default.. + # - involve error-prone configurations distant to the main state transition configuration in stateMatrix + if {[dict exists $::tomlish::parse::spacePopTransitions $parentspace]} { + set next [dict get $::tomlish::parse::spacePopTransitions $parentspace] + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace redirected state to $next (spacePopTransitions)<<---" + } else { + set next $parentspace + ::tomlish::log::info "--->> POPSPACE transition from $popfromspace_state to parent space $parentspace<<---" + } + } + set result $next + } + SAMESPACE { + set currentspace_info [spacestack peek] + ::tomlish::log::debug "--->> SAMESPACE got current space entry: $currentspace_info <<<<<" + set type [dict get $currentspace_info type] + set currentspace [dict get $currentspace_info state] + + if {[dict exists $currentspace_info returnstate]} { + set next [dict get $currentspace_info returnstate] + #clear the returnstate on current level + set existing [spacestack pop] + dict unset existing returnstate + spacestack push $existing ;#re-push modification + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected to stored returnstate $next" + } else { + if {[dict exists $::tomlish::parse::spaceSameTransitions $currentspace]} { + set next [dict get $::tomlish::parse::spaceSameTransitions $currentspace] + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace redirected state to $next (spaceSameTransitions)" + } else { + set next $currentspace + ::tomlish::log::info "--->> SAMESPACE transition to space $currentspace" + } + } + set result $next + } + zeropoppushspace { + if {$nest > 0} { + #pop back down to the root level (table-space) + spacestack pop + set parentinfo [spacestack peek] + set type [dict get $parentinfo type] + set target [dict get $parentinfo state] + + set last_space_action "pop" + set last_space_type $type + + #----- + #standard pop + set parentlevel [expr {$nest -1}] + lappend v($parentlevel) [set v($nest)] + incr nest -1 + #----- + } + #re-entrancy + + #set next [list PUSHSPACE [lindex $transition_to 1]] + set nexttokentype ${tokentype}2 ;#fake token type e.g tablename2 or tablearrayname2 + ::tomlish::log::debug "--->> zeropoppushspace goNextState RECURSE. calling goNextState $nexttokentype $currentstate" + set transition_info [::tomlish::parse::goNextState $nexttokentype $tok $currentstate] + set result [dict get $transition_info newstate] + } + PUSHSPACE { + set original_target [dict get $transition_to PUSHSPACE] + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + if {[dict exists $transition_to starttok]} { + set starttok [dict get $transition_to starttok] + } + spacestack push [dict create type space state $original_target] + + set last_space_action "push" + set last_space_type "space" + + if {[dict exists $transition_to state]} { + #an explicit state in the pushed space was requested in the stateMatrix - override the spacePushTransition (spacePushTransitions can be deprecated if we require explicitness?) + set next [dict get $transition_to state] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next by explicit 'state' entry" + } else { + #puts $::tomlish::parse::spacePushTransitions + if {[dict exists $::tomlish::parse::spacePushTransitions $original_target]} { + set next [dict get $::tomlish::parse::spacePushTransitions $original_target] + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target redirected state to $next (spacePushTransitions) " + } else { + set next $original_target + ::tomlish::log::info "--->> PUSHSPACE transition to space $original_target" + } + } + set result $next + } + TOSTATE { + if {[dict exists $transition_to returnstate]} { + #adjust the existing space record on the stack. + #struct::stack doesn't really support that - so we have to pop and re-push + #todo - investigate a custom stack implementation where we can efficiently lset the top of the stack + set currentspace [spacestack pop] + dict set currentspace returnstate [dict get $transition_to returnstate] + spacestack push $currentspace ;#return modified info to stack so when we POPSPACE the returnstate is available. + } + set result [dict get $transition_to TOSTATE] + } + default { + #simplified version of TOSTATE + set result [lindex $transition_to 0] ;#ignore everything but first word + } + } + } else { + ::tomlish::log::error "--->> No state transition defined from state $currentstate when tokentype $tokentype received" + set result "nostate" + } + lappend state_list [list tokentype $tokentype from $currentstate to $result] + set state $result + ::tomlish::log::notice "--->> STATE TRANSITION tokenType: '$tokentype' tok:$tok triggering '$currentstate' -> '$result' last_space_action:$last_space_action " + return [dict create prevstate $prevstate newstate $result space_action $last_space_action starttok $starttok] + } + + proc report_line {{line ""}} { + variable linenum + variable is_parsing + if {$is_parsing} { + if {$line eq ""} { + set line $linenum + } + return "Line Number: $line" + } else { + #not in the middle of parsing tomlish text - return nothing. + return "" + } + } + + #produce a *slightly* more readable string rep of the nest for puts etc. + proc nest_pretty1 {list} { + set prettier "{" + + foreach el $list { + if { [lindex $el 0] eq "NEWLINE"} { + append prettier "[list $el]\n" + } elseif {([llength $el] > 1) && ([lindex $el 0] in {KEY DQKEY SQKEY TABLE ARRAY})} { + append prettier [nest_pretty1 $el] + } else { + append prettier "[list $el] " + } + } + append prettier "}" + return $prettier + } + + proc set_tokenType {t} { + variable tokenType + variable tokenType_list + if {![info exists tokenType]} { + set tokenType "" + } + lappend tokenType_list $t + set tokenType $t + } + + proc switch_tokenType {t} { + variable tokenType + variable tokenType_list + lset tokenType_list end $t + set tokenType $t + } + + proc get_tokenType {} { + variable tokenType + return $tokenType + } + + + proc get_token_waiting {} { + variable token_waiting + return [lindex $token_waiting 0] + } + proc clear_token_waiting {} { + variable token_waiting + set token_waiting [list] + } + + #token_waiting is a list - but our standard case is to have only one + #in certain circumstances such as near eof we may have 2 + #the set_token_waiting function only allows setting when there is not already one waiting. + #we want to catch cases of inadvertently trying to set multiple + # - the reason being that the state transition triggered by the previous token may have invalidated the assumptions made when a token was added as waiting. + proc set_token_waiting {args} { + if {[llength $args] %2 != 0} { + error "tomlish set_token_waiting must have args of form: type value complete 0|1" + } + variable token_waiting + + if {[llength $token_waiting] && [dict get [lindex $token_waiting end] type] ne "eof"} { + #tokloop already set a token_waiting - but something (post tokloop processing?) is trying to set another + #we may need to remove the existing token_waiting and reset the tokloop index to the previous char so it's reprocessed in the possibly new context + #rather than attempt to make the right decision here - we raise an error and require the caller to check/handle it + set err "tomlish set_token_waiting already has token_waiting: [lindex $token_waiting 0]" + append err \n " - cannot add token_waiting: $args" + error $err + #set tomlish::parse::i [expr {[dict get $token_waiting startindex] -1}] + #set token_waiting [list] + } + + set waiting [dict create] + dict for {k v} $args { + switch -exact $k { + type - complete { + dict set waiting $k $v + } + value { + dict set waiting tok $v + } + startindex { + dict set waiting startindex $v + } + default { + error "tomlish set_token_waiting error - unrecognised key $k. known keys: [dict keys $args]" + } + } + } + if {![tcl::string::is boolean -strict [dict get $waiting complete]]} { + error "tomlish set_token_waiting error - 'complete' must be a boolean. got [dict get $waiting complete]" + } + if {![llength $token_waiting]} { + set token_waiting [list $waiting] + } else { + #an extra sanity-check that we don't have more than just the eof.. + if {[llength $token_waiting] > 1} { + set err "tomlish Unexpected. Existing token_waiting count > 1.\n" + foreach tw $token_waiting { + append err " $tw" \n + } + append err " - cannot add token_waiting: $waiting" + error $err + } + #last entry must be a waiting eof + set token_waiting [list $waiting [lindex $token_waiting end]] + } + return + } + + #returns 0 or 1 + #tomlish::parse::tok + #we attempt to do this without lookahead (potential use in streaming toml? for what benefit?) todo -final flag + # - the possible benefit is being able to more easily process in arbitrarily split chunks (although we would still have to watch crlf splitting ?) + # - interactive use? + + proc tok {s} { + variable nest + variable v + variable i + variable tok + variable type ;#character type + variable state ;#FSM + + + variable tokenType + variable tokenType_list + + + variable endToken + + variable lastChar + + variable braceCount + variable bracketCount + + + #------------------------------ + #Previous run found another (presumably single-char) token + #The normal case is for there to be only one dict in the list + #multiple is an exception - primarily for eof + variable token_waiting + if {[llength $token_waiting]} { + set waiting [lindex $token_waiting 0] + + set tokenType [dict get $waiting type] + set tok [dict get $waiting tok] + #todo: dict get $token_waiting complete + set token_waiting [lrange $token_waiting 1 end] + return 1 + } + #------------------------------ + + set resultlist [list] + set sLen [tcl::string::length $s] + + set slash_active 0 + set quote 0 + set c "" + for {} {$i < $sLen} {} { + if {$i > 0} { + set lastChar [tcl::string::index $s [expr {$i - 1}]] + } else { + set lastChar "" + } + + set c [tcl::string::index $s $i] + set cindex $i + set ctest [tcl::string::map {\{ lc \} rc \[ lb \] rb \" dq ' sq \\ bsl \r cr \n lf \t tab \uFEFF bom} $c] + tomlish::log::debug "- tokloop char <$ctest> index $i tokenType:$tokenType tok:<$tok>" + #puts "got char $c during tokenType '$tokenType'" + incr i ;#must incr here because we do returns inside the loop + + switch -exact -- $ctest { + # { + set had_slash $slash_active + set slash_active 0 + + if {$had_slash} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + #for multiliteral, multistring - data and/or end + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo token beginning with underscore - never returned to state machine - review + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]" + } + whitespace { + # hash marks end of whitespace token + #do a return for the whitespace, set token_waiting + #set_token_waiting type comment value "" complete 1 + incr i -1 ;#leave comment for next run + return 1 + } + untyped_value { + #REVIEW! the spec isn't clear.. is whitespace after an int,bool etc required before comment? + #we will accept a comment marker as an immediate terminator of the untyped_value. + incr i -1 + return 1 + } + starttablename - starttablearrayname { + #fix! + error "tomlish Character '#' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare parts - but allowed in quoted parts - let tablename parser sort it out + append tok $c + } + default { + #dquotedkey, string,literal, multistring + append tok $c + } + } + } else { + switch -- $state { + multistring-space { + set_tokenType stringpart + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "#" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "#" + } + default { + #start of token if we're not in a token + set_tokenType comment + set tok "" ;#The hash is not part of the comment data + } + } + } + } + lc { + #left curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i [tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + #*bare* tablename can only contain letters,digits underscores + error "tomlish Invalid tablename first character \{ [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #valid in quoted parts + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\{" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + switch -exact -- $state { + itable-keyval-value-expected - keyval-value-expected { + #switch last key to tablename?? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + array-space - array-syntax { + #nested anonymous inline table + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "startinlinetable" + set tok "\{" + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\{" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\{" + } + default { + error "tomlish state: '$state'. left brace case not implemented [tomlish::parse::report_line]" + } + } + } + + } + rc { + #right curly brace + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey - comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - tablename { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endinlinetable value "" complete 1 startindex $cindex + return 1 + } + starttablearrayname - tablearrayname { + if {$had_slash} {append tok "\\"} + #invalid! - but leave for datastructure loading stage to catch + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } + default { + #end any other token + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-space { + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname-state problem" + set_tokenType "endinlinetable" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + array-syntax - array-space { + #invalid + set_tokenType "endinlinetable" + set tok "\}" + return 1 + } + itable-val-tail { + set_tokenType "endinlinetable" + set tok "" + #we need to pop the keyval - and then reprocess to pop the inlinetable - so we incr -1 + incr i -1 + return 1 + } + itable-keyval-syntax { + error "tomlish endinlinetable unexpected at this point. Expecting key=val syntax [tomlish::parse::report_line]" + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\}" + } + multiliteral-space { + set_tokenType "literalpart" ; #review + set tok "\}" + } + default { + #JMN2024b keyval-tail? + error "tomlish state '$state'. endinlinetable case not implemented [tomlish::parse::report_line]" + } + } + } + + } + lb { + #left square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename { + #change the tokenType + switch_tokenType "starttablearrayname" + set tok "" ;#no output into the tomlish list for this token + #any following whitespace is part of the tablearrayname, so return now + return 1 + } + tablename - tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + #append tok "\\[" + append tok {\[} + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + #invalid at this point - state machine should disallow: + # table -> starttablearrayname + # tablearray -> starttablearrayname + set_token_waiting type starttablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "\[" + } + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok "\[" + } + default { + #end any other token. + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + keyval-value-expected - itable-keyval-value-expected { + set_tokenType "startarray" + set tok "\[" + return 1 + } + array-space - array-syntax { + #nested array? + set_tokenType "startarray" + set tok "\[" + return 1 + #error "state: array-space. startarray case not implemented [tomlish::parse::report_line]" + } + table-space { + #table name + #assume it's a single bracket - but we need to wait for non-bracket to confirm it's not a tablearray + #note that a starttablearrayname token may contain whitespace between the brackets + # e.g \[ \[ + set_tokenType "starttablename" + set tok "" ;#there is no output into the tomlish list for this token + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\[" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\[" + } + itable-space { + #handle state just to give specific error msg + error "tomlish state: '$state'. Left square bracket invalid. Cannot start array in inline table without key. Use key=\[\] syntax. [tomlish::parse::report_line]" + } + default { + error "tomlish state: '$state'. startarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + rb { + #right square bracket + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + #???? + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } else { + incr i -1 + if {$had_slash} {incr i -1} ;#reprocess + return 1 + } + } + tablename { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablename value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + tablearrayname { + #e.g a."x[0]".c is valid table name sequence - so we need to track quoting to know if rb is an end token + if {$had_slash} { + #resultant tablename may be invalid - but leave for datastructure loading stage to catch + append tok "\\]" + } else { + if {[tomlish::utils::tok_in_quotedpart $tok] eq ""} { + set_token_waiting type endtablearrayname value "" complete 1 startindex $cindex + return 1 + } else { + #we appear to still be in single or double quoted section + append tok "]" + } + } + } + default { + incr i -1 + return 1 + } + } + } else { + #$slash_active not relevant when no tokenType + switch -exact -- $state { + array-syntax - array-space { + #invalid - but allow parser statemachine to report it. + set_tokenType "endarray" + set tok "\]" + return 1 + } + table-space { + #invalid - but allow parser statemachine to report it. ? + set_tokenType "endarray" + set tok "\]" + return 1 + } + tablename-state { + #e.g [] - empty tablename - allowed or not? + #empty tablename/tablearrayname ? + #error "unexpected tablename problem" + + set_tokenType "endtablename" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-state { + error "tomlish unexpected tablearrayname problem" + set_tokenType "endtablearray" + set tok "" ;#no output into the tomlish list for this token + return 1 + } + tablearrayname-tail { + #[[xxx] + set_tokenType "endtablename" + #sequence: starttablename -> starttablearrayname -> endtablearrayname -> endtablename + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok "\]" + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\]" + } + default { + error "tomlish state '$state'. endarray case not implemented [tomlish::parse::report_line]" + } + } + } + } + bsl { + #backslash + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + #end whitespace token + incr i -1 ;#reprocess bsl in next run + return 1 + } else { + error "tomlish Unexpected backslash during whitespace. [tomlish::parse::report_line]" + } + } + literal - literalpart - squotedkey { + #never need to set slash_active true when in single quoted tokens + append tok "\\" + set slash_active 0 + } + string - dquotedkey - comment { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + stringpart { + if {$slash_active} { + #assert - quotes empty - or we wouldn't have slash_active + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + starttablename - starttablearrayname { + error "tomlish backslash is invalid as first character of $tokenType [tomlish::parse::report_line]" + } + tablename - tablearrayname { + if {$slash_active} { + set slash_active 0 + append tok "\\\\" + } else { + set slash_active 1 + } + } + barekey { + error "tomlish Unexpected backslash during barekey. [tomlish::parse::report_line]" + } + default { + error "tomlish Backslash unexpected during tokentype: '$tokenType'. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$slash_active} { + set_tokenType "stringpart" + set tok "\\\\" + set slash_active 0 + } else { + set slash_active 1 + } + } + multiliteral-space { + #nothing can be escaped in multiliteral-space - not even squotes (?) review + set_tokenType "literalpart" + set tok "\\" + } + default { + error "tomlish tok error: Unexpected backslash when no token is active. [tomlish::parse::report_line]" + } + } + } + } + sq { + #single quote + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + #for within multiliteral + #short tentative_accum_squote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_squote is multisquote + 2 = 5 + #return tok with value ''''' + return 1 + } + } + tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multiliteral + #switch? + append tok $c + set_tokenType triple_squote + return 1 + } + default { + #if there are more than 3 leading squotes we also enter multiliteral space and the subsequent ones are handled + #by the tentative_accum_squote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 squotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_squote_sequence'" + } + } + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + #end whitespace + incr i -1 ;#reprocess sq + return 1 + } + literal { + #slash_active always false + #terminate the literal + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + literalpart { + #ended by ''' - but final could be '''' or ''''' (up to 2 squotes allowed directly before ending triple squote sequence) + #todo + # idea: end this literalpart (possibly 'temporarily') + # let the sq be reprocessed in the multiliteral-space to push an end-multiliteral-sequence to state stack + # upon popping end-multiliteral-sequence - stitch quotes back into this literalpart's token (if either too short - or a long ending sequence as shown above) + incr i -1 ;#throw the "'" back to loop - will be added to a tentative_accum_squote token for later processing + return 1 + } + XXXitablesquotedkey { + set_token_waiting type endsquote value "'" complete 1 startindex $cindex + return 1 + } + squotedkey { + ### + #set_token_waiting type endsquote value "'" complete 1 + return 1 + } + starttablename - starttablearrayname { + #!!! + incr i -1 + return 1 + } + tablename - tablearrayname { + append tok $c + } + barekey { + #barekeys now support all sorts of unicode letter/number chars for other cultures + #but not punctuation - not even for those of Irish heritage who don't object + #to the anglicised form of some names. + # o'shenanigan seems to not be a legal barekey + #The Irish will have to use an earlier form Ó - which apparently many may prefer anyway. + error "tomlish Unexpected single quote during barekey. [tomlish::parse::report_line]" + } + default { + append tok $c + } + } + } else { + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading squote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_squote token or triple_squote token + #It currently doesn't trigger double_squote token + #(handle '' same as 'x' ie produce a single_squote and go into processing literal) + #review - producing double_squote for empty literal may be slightly more efficient. + #This token is not used to handle squote sequences *within* a multiliteral + set_tokenType "_start_squote_sequence" + set tok "'" + } + multiliteral-space { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_squote" ;#trigger tentative_accum_squote + set tok "'" + return 1 + } + table-space - itable-space { + #tests: squotedkey.test squotedkey_itable.test + set_tokenType "squotedkey" + set tok "" + } + XXXtable-space - XXXitable-space { + #future - could there be multiline keys? MLLKEY, MLBKEY ? + #this would (almost) allow arbitrary tcl dicts to be stored in toml (aside from escaping issues) + #probably unlikely - as it's perhaps not very 'minimal' or ergonomic for config files + #@2025 ABNF for toml mentions key, simple-key, unquoted-key, quoted-key and dotted-key + #where key is simple-key or dotted-key - no MLL or MLB components + #the spec states solution for arbitrary binary data is application specific involving encodings + #such as hex, base64 + set_tokenType "_start_squote_sequence" + set tok "'" + return 1 + } + tablename-state { + #first char in tablename-state/tablearrayname-state + set_tokenType "tablename" + append tok "'" + } + tablearrayname-state { + set_tokenType "tablearrayname" + append tok "'" + } + literal-state { + #shouldn't get here? review + tomlish::log::debug "- tokloop sq during literal-state with no tokentype - empty literal?" + set_tokenType "literal" + incr -1 + return 1 + } + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + #error "tomlish unimplemented - squote during state '$state'. [tomlish::parse::report_line]" + } + dottedkey-space { + set_tokenType "squotedkey" + } + default { + error "tomlish unhandled squote during state '$state'. [tomlish::parse::report_line]" + } + } + } + + } + dq { + #double quote + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + tentative_accum_dquote { + #within multistring + #short tentative_accum_dquote tokens are returned if active upon receipt of any other character + #longest allowable for leading/trailing are returned here + #### + set existingtoklen [tcl::string::length $tok] ;#toklen prior to this squote + #assert state = trailing-squote-space + append tok $c + if {$existingtoklen == 4} { + #maxlen to be a tentative_accum_dquote is multidquote + 2 = 5 + #return tok with value """"" + return 1 + } + } + _start_dquote_sequence { + #pseudo/temp token creatable during keyval-value-expected itable-keyval-value-expected or array-space + switch -- [tcl::string::length $tok] { + 1 { + #no conclusion can yet be reached + append tok $c + } + 2 { + #enter multistring + #switch? + append tok $c + set_tokenType triple_dquote + return 1 + } + default { + #if there are more than 3 leading dquotes we also enter multistring space and the subsequent ones are handled + #by the tentative_accum_dquote check for ending sequence which can accept up to 5 and reintegrate the + #extra 1 or 2 dquotes as data. + error "tomlish unexpected token length [tcl::string::length $tok] in '_start_dquote_sequence'" + } + } + } + literal - literalpart { + append tok $c + } + string { + if {$had_slash} { + append tok "\\" $c + } else { + #unescaped quote always terminates a string + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + stringpart { + #sub element of multistring + if {$had_slash} { + append tok "\\" $c + } else { + incr i -1 ;#throw the {"} back to loop - will be added to a tentative_accum_dquote token for later processing + return 1 + } + } + whitespace { + #assert: had_slash will only ever be true in multistring-space + if {$had_slash} { + incr i -2 + return 1 + } else { + #end whitespace token - throw dq back for reprocessing + incr i -1 + return 1 + } + } + comment { + if {$had_slash} {append tok "\\"} + append tok $c + } + XXXdquotedkey { + if {$had_slash} { + append tok "\\" + append tok $c + } else { + set_token_waiting type enddquote value "\"" complete 1 startindex $cindex + return 1 + } + } + dquotedkey { + ### + if {$had_slash} { + append tok "\\" + append tok $c + } else { + #set_token_waiting type enddquote value {"} complete 1 + return 1 + } + } + squotedkey { + append tok $c + } + tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok $c + } + starttablename - starttablearrayname { + incr i -1 ;## + return 1 + } + default { + error "tomlish got quote during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + #$slash_active not relevant when no tokenType + #token is string only if we're expecting a value at this point + switch -exact -- $state { + array-space - keyval-value-expected - itable-keyval-value-expected { + #leading dquote + #pseudo-token _start_squote_sequence ss not received by state machine + #This pseudotoken will trigger production of single_dquote token or triple_dquote token + #It currently doesn't trigger double_dquote token + #(handle "" same as "x" ie produce a single_dquote and go into processing string) + #review - producing double_dquote for empty string may be slightly more efficient. + #This token is not used to handle dquote sequences once *within* a multistring + set_tokenType "_start_dquote_sequence" + set tok {"} + } + multistring-space { + if {$had_slash} { + set_tokenType "stringpart" + set tok "\\\"" + } else { + #each literalpart is not necessarily started/ended with squotes - but may contain up to 2 in a row + #we are building up a tentative_accum_squote to determine if + #a) it is shorter than ''' so belongs in a literalpart (either previous, subsequent or it's own literalpart between newlines + #b) it is exactly ''' and we can terminate the whole multiliteral + #c) it is 4 or 5 squotes where the first 1 or 2 beling in a literalpart and the trailing 3 terminate the space + set_tokenType "tentative_trigger_dquote" ;#trigger tentative_accum_dquote + set tok {"} + return 1 + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok "\"" + } + table-space - itable-space { + set_tokenType "dquotedkey" + set tok "" + } + dottedkey-space { + set_tokenType dquotedkey + set tok "" + + #only if complex keys become a thing + #set_tokenType dquote_seq_begin + #set tok $c + } + tablename-state { + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + default { + error "tomlish Unexpected dquote during state '$state' [tomlish::parse::report_line]" + } + } + } + } + = { + set had_slash $slash_active + set slash_active 0 + + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart - squotedkey { + #assertion had_slash 0 + append tok $c + } + string - comment - dquotedkey { + #for these tokenTypes an = is just data. + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type equal value = complete 1 startindex $cindex + return 1 + } + } + barekey { + #set_token_waiting type equal value = complete 1 + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character '=' is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #invalid in bare name - but valid in quoted parts - leave for tablename parser to sort out + append tok $c + } + default { + error "tomlish unexpected = character during tokentype $tokenType. case not implemented. [tomlish::parse::report_line]" + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} { + append tok "\\" + } + append tok = + } + multiliteral-space { + set_tokenType "literalpart" + set tok "=" + } + dottedkey-space { + set_tokenType "equal" + set tok "=" + return 1 + } + default { + set_tokenType "equal" + set tok = + return 1 + } + } + } + } + cr { + #REVIEW! + # \r carriage return + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #we have received a double cr + ::tomlish::log::warn "double cr - will generate cr token. needs testing" + set_tokenType "cr" ;#lone cr token will generally raise an error - but let state machine handle it + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + append tok $c + } + literalpart { + #part of MLL string (multi-line literal string) + #we need to split out crlf as a separate NEWLINE to be consistent + ::tomlish::log::warn "literalpart ended by cr - needs testing" + #return literalpart temporarily - allow cr to be reprocessed from multiliteral-space + incr i -1 + return 1 + } + stringpart { + #stringpart is a part of MLB string (multi-line basic string) + #throw back the cr - if followed by lf it will become a {NEWLINE crlf} entry within the MULTISTRING list (e.g between STRINGPART entries) + incr i -1 + return 1 + } + starttablename - starttablearrayname { + error "tomlish Character is invalid first character for $tokenType. [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #could in theory be valid in quoted part of name + #review - might be better just to disallow here + append tok $c + } + whitespace { + #it should technically be part of whitespace if not followed by lf + #but outside of values we are also free to map it to be another NEWLINE instead? REVIEW + incr i -1 + return 1 + } + untyped_value { + incr i -1 + return 1 + } + default { + #!todo - error out if cr inappropriate for tokenType + append tok $c + } + } + } else { + #lf may be appended if next + #review - lone cr as newline? - this is uncommon - but so is lone cr in a string(?) + set_tokenType "newline" + set tok cr + } + } + lf { + # \n newline + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #review + #this lf is the trailing part of a crlf + append tok lf ;#assert we should now have tok "crlf" - as a previous cr is the only way to have an incomplete newline tok + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + #multiliteral or multistring + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal { + #nl is not allowed *within* a literal - require multiliteral syntax for any literal containing a newline ''' ''' + #even though we terminate the literal without the closing quote here - the token_waiting newline should trigger a state error + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + literalpart { + #we allow newlines - but store them within the multiliteral as their own element + #This is a legitimate end to the literalpart - but not the whole multiliteral + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + stringpart { + if {$had_slash} { + #emit the stringpart (return 1), queue the continuation, go back 1 to reprocess the lf (incr i -1) + set_token_waiting type continuation value \\ complete 1 startindex [expr {$cindex-1}] + incr i -1 + return 1 + } else { + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + starttablename - tablename - tablearrayname - starttablearrayname { + error "tomlish Character is invalid in $tokenType. [tomlish::parse::report_line]" + } + default { + #newline ends all other tokens. + #note for string: we don't add (raw unescaped) newline to simple string. (must use multi-string for this) + #note for whitespace: + # we will use the convention that \n terminates the current whitespace even if whitespace follows + # ie whitespace is split into separate whitespace tokens at each newline + + #puts "-------------- newline lf during tokenType $tokenType" + set_token_waiting type newline value lf complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "newline" + set tok lf + return 1 + } + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "newline" + set tok "lf" + return 1 + } + default { + #ignore slash? error? + set_tokenType "newline" + set tok lf + return 1 + } + } + #if {$had_slash} { + # #CONT directly before newline - allows strings_5_byteequivalent test to pass + # set_tokenType "continuation" + # set tok "\\" + # incr i -1 + # return 1 + #} else { + # set_tokenType newline + # set tok lf + # return 1 + #} + } + } + , { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - tablename - tablearrayname { + if {$had_slash} {append tok "\\"} + append tok , + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + #stringpart can have up to 2 quotes too + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + set_token_waiting type comma value "," complete 1 startindex $cindex + return 1 + } + } + default { + set_token_waiting type comma value "," complete 1 startindex $cindex + if {$had_slash} {append tok "\\"} + return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "," + } + multiliteral-space { + #assert had_slash 0 + set_tokenType "literalpart" + set tok "," + } + default { + set_tokenType "comma" + set tok "," + return 1 + } + } + } + } + . { + set had_slash $slash_active + set slash_active 0 + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + comment - untyped_value { + if {$had_slash} {append tok "\\"} + append tok $c + } + string - dquotedkey { + if {$had_slash} {append tok "\\"} + append tok $c + } + stringpart { + if {$had_slash} {append tok "\\"} + append tok $c + } + literal - literalpart - squotedkey { + #assert had_slash always 0 + append tok $c + } + whitespace { + switch -exact -- $state { + multistring-space { + #review + if {$had_slash} { + incr i -2 + } else { + incr i -1 + } + return 1 + } + xxxdottedkey-space { + incr i -1 + return 1 + } + dottedkey-space-tail { + incr i -1 + return 1 + } + default { + error "tomlish Received period during tokenType 'whitespace' [tomlish::parse::report_line]" + } + } + } + starttablename - starttablearrayname { + #This would correspond to an empty table name + error "tomlish Character '.' is not allowed as first character ($tokenType). [tomlish::parse::report_line]" + } + tablename - tablearrayname { + #subtable - split later - review + append tok $c + } + barekey { + #e.g x.y = 1 + #we need to transition the barekey to become a structured table name ??? review + #x is the tablename y is the key + set_token_waiting type dotsep value "." complete 1 startindex $cindex + return 1 + } + default { + error "tomlish Received period during tokenType '$tokenType' [tomlish::parse::report_line]" + #set_token_waiting type period value . complete 1 + #return 1 + } + } + } else { + switch -exact -- $state { + multistring-space { + set_tokenType "stringpart" + set tok "" + if {$had_slash} {append tok "\\"} + append tok "." + } + multiliteral-space { + set_tokenType "literalpart" + set tok "." + } + XXXdottedkey-space { + ### obs? + set_tokenType "dotsep" + set tok "." + return 1 + } + dottedkey-space-tail { + ### + set_tokenType "dotsep" + set tok "." + return 1 + } + default { + set_tokenType "untyped_value" + set tok "." + } + } + } + + } + " " { + if {[tcl::string::length $tokenType]} { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #todo had_slash - emit token or error + #whitespace is a terminator for bare keys + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + comment { + if {$had_slash} { + append tok "\\" + } + append tok $c + } + string - dquotedkey { + if {$had_slash} { append tok "\\" } + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART xxx WS " " + incr i -1 + return 1 + } + } + literal - literalpart - squotedkey { + append tok $c + } + whitespace { + if {$state eq "multistring-space"} { + append tok $c + } else { + append tok $c + } + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace space during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok "" + if {$had_slash} {append tok "\\"} + append tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType "whitespace" + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + if {$had_slash} { + error "tomlish unexpected backslash [tomlish::parse::report_line]" + } + set_tokenType "whitespace" + append tok $c + } + } + } + } + tab { + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out (?review) + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + barekey { + #whitespace is a terminator for bare keys + incr i -1 + #set_token_waiting type whitespace value $c complete 1 + return 1 + } + untyped_value { + #unquoted values (int,date,float etc) are terminated by whitespace + #set_token_waiting type whitespace value $c complete 1 + incr i -1 + return 1 + } + squotedkey { + append tok $c + } + dquotedkey - string - comment - whitespace { + #REVIEW + append tok $c + } + stringpart { + #for stringpart we store WS separately for ease of processing continuations (CONT stripping) + if {$had_slash} { + #REVIEW + #emit the stringpart - go back to the slash + incr i -2 + return 1 + } else { + #split into STRINGPART aaa WS " " + incr i -1 + return 1 + } + } + literal - literalpart { + append tok $c + } + starttablename - starttablearrayname { + incr i -1 + return 1 + } + tablename - tablearrayname { + #include whitespace in the tablename/tablearrayname + #Will need to be normalized upon interpreting the tomlish as a datastructure + append tok $c + } + default { + error "tomlish Received whitespace tab during tokenType '$tokenType' [tomlish::parse::report_line]" + } + } + } else { + set had_slash $slash_active + if {$slash_active} { + set slash_active 0 + } + switch -exact -- $state { + tablename-state { + #tablename can have leading,trailing and interspersed whitespace! + #These will not be treated as whitespace tokens, instead forming part of the name. + set_tokenType tablename + set tok $c + } + tablearrayname-state { + set_tokenType tablearrayname + set tok $c + } + multistring-space { + if {$had_slash} { + set_tokenType "continuation" + set tok "\\" + incr i -1 + return 1 + } else { + set_tokenType whitespace + append tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + default { + set_tokenType "whitespace" + append tok $c + } + } + } + } + bom { + #BOM (Byte Order Mark) - ignored by token consumer + if {[tcl::string::length $tokenType]} { + switch -exact -- $tokenType { + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + #assert - tok will be one or two squotes only + #A toml literal probably isn't allowed to contain this + #but we will parse and let the validator sort it out. + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + literal - literalpart { + append tok $c + } + string - stringpart { + append tok $c + } + default { + #state machine will generally not have entry to accept bom - let it crash + set_token_waiting type bom value "\uFEFF" complete 1 startindex $cindex + return 1 + } + } + } else { + switch -exact -- $state { + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + multistring-space { + set_tokenType "stringpart" + set tok $c + } + default { + set_tokenType "bom" + set tok "\uFEFF" + return 1 + } + } + } + } + default { + + if {[tcl::string::length $tokenType]} { + if {$slash_active} {append tok "\\"} ;#if tokentype not appropriate for \, we would already have errored out. + set slash_active 0 + switch -exact -- $tokenType { + newline { + #incomplete newline + set_tokenType "cr" + incr i -1 + return 1 + } + tentative_accum_squote - tentative_accum_dquote { + incr i -1 + return 1 + } + _start_squote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_squote" + return 1 + } + _start_dquote_sequence { + incr i -[tcl::string::length $tok] + set_tokenType "single_dquote" + return 1 + } + whitespace { + if {$state eq "multistring-space"} { + incr i -1 + return 1 + } else { + #review + incr i -1 ;#We don't have a full token to add to the token_waiting dict - so leave this char for next run. + return 1 + } + } + barekey { + if {[tomlish::utils::is_barekey $c]} { + append tok $c + } else { + error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]" + } + } + starttablename - starttablearrayname { + incr i -1 + #allow statemachine to set context for subsequent chars + return 1 + } + stringpart { + append tok $c + } + default { + #e.g comment/string/literal/literalpart/untyped_value/starttablename/starttablearrayname/tablename/tablearrayname + append tok $c + } + } + } else { + set had_slash $slash_active + set slash_active 0 + switch -exact -- $state { + table-space - itable-space { + #if no currently active token - assume another key value pair + if {[tomlish::utils::is_barekey $c]} { + set_tokenType "barekey" + append tok $c + } else { + error "tomlish Unexpected char $c ([tomlish::utils::nonprintable_to_slashu $c]) whilst no active tokenType. [tomlish::parse::report_line]" + } + } + multistring-space { + set_tokenType "stringpart" + if {$had_slash} { + set tok \\$c + } else { + set tok $c + } + } + multiliteral-space { + set_tokenType "literalpart" + set tok $c + } + tablename-state { + set_tokenType "tablename" + set tok $c + } + tablearrayname-state { + set_tokenType "tablearrayname" + set tok $c + } + dottedkey-space { + set_tokenType barekey + set tok $c + } + default { + #todo - something like ansistring VIEW to show control chars? + set cshow [string map [list \t tab \v vt] $c] + tomlish::log::debug "- tokloop char '$cshow' setting to untyped_value while state:$state [tomlish::parse::report_line]" + set_tokenType "untyped_value" + set tok $c + } + } + } + } + } + + } + + #run out of characters (eof) + if {[tcl::string::length $tokenType]} { + #check for invalid ending tokens + #if {$state eq "err-state"} { + # error "Reached end of data whilst tokenType = '$tokenType'. INVALID" + #} + switch -exact -- $tokenType { + _start_squote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open literal + error "tomlish eof reached without closing single quote for string literal. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "literal" + set tok "" + return 1 + + ##review + #set_token_waiting type endsquote value "'" complete 1 startindex [expr {$cindex -1}] + #set_tokenType "literal" + #set tok "" + #return 1 + } + } + } + _start_dquote_sequence { + set toklen [tcl::string::length $tok] + switch -- $toklen { + 1 { + #invalid eof with open string + error "tomlish eof reached without closing double quote for string. [tomlish::parse::report_line]" + } + 2 { + set_tokenType "string" + set tok "" + return 1 + } + } + } + newline { + #The only newline token that has still not been returned should have a tok value of "cr" + puts "tomlish eof reached - with incomplete newline token '$tok'" + if {$tok eq "cr"} { + #we convert lone cr to it's own "cr" token elsewhere in the document to allow statemachine to handle it. + #(which it should generally do by not handling it ie raising an error - or emitting an ERROR list in the tomlish) + #if trailing char is a lone cr - we should encode it the same way as elsewhere that is outside of values + # ie as it's own token. + switch_tokenType "cr" + return 1 + } else { + #should be unreachable + error "tomlish eof reached - with invalid newline token. value: $tok" + } + } + } + set_token_waiting type eof value eof complete 1 startindex $i ;#review + return 1 + } else { + ::tomlish::log::debug "- No current tokenType, ran out of characters, setting tokenType to 'eof' [tomlish::parse::report_line]" + set tokenType "eof" + set tok "eof" + } + return 0 + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::parse ---}] +} + +namespace eval tomlish::dict { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + + proc is_tomlish_typeval {d} { + #designed to detect {type value } e.g {type INT value 3}, {type STRING value "blah etc"} + #as a sanity check we need to avoid mistaking user data that happens to match same form + #consider x.y={type="spud",value="blah"} + #The value of type will itself have already been converted to {type STRING value spud} ie never a single element. + #check the length of the type as a quick way to see it's a tag - not something else masqerading. + expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1} + } + proc is_tomlish_typeval2 {d} { + upvar ::tomlish::tags tags + expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags} + } + proc last_tomltype_posn {d} { + set last_simple -1 + set dictposn [expr {[dict size $d] -1}] + foreach k [lreverse [dict keys $d]] { + set dval [dict get $d $k] + if {[is_tomlish_typeval $dval]} { + set last_simple $dictposn + break + } + incr dictposn -1 + } + return $last_simple + } + + + #review + proc name_from_tablestack {tablestack} { + set name "" + foreach tinfo [lrange $tablestack 1 end] { + lassign $tinfo type namepart + switch -- $type { + T { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + I { + if {$name eq ""} { + append name $namepart + } else { + append name .$namepart + } + } + default { + #end at first break in the leading sequence of T & I tablenames + break + } + } + } + return $name + } + + proc _show_tablenames {tablenames_info} { + append msg \n "tablenames_info:" \n + dict for {tkey tinfo} $tablenames_info { + append msg " " "table: $tkey" \n + dict for {field finfo} $tinfo { + append msg " " "$field $finfo" \n + } + } + return $msg + } +} +tcl::namespace::eval tomlish::to_dict { + proc tablename_split {tablename {normalize false}} { + #we can't just split on . because we have to handle quoted segments which may contain a dot. + #eg {dog."tater.man"} + set sLen [tcl::string::length $tablename] + set segments [list] + set mode "preval" ;#5 modes: preval, quoted,litquoted, unquoted, postval + #quoted is for double-quotes, litquoted is for single-quotes (string literal) + set seg "" + for {set i 0} {$i < $sLen} {incr i} { + + if {$i > 0} { + set lastChar [tcl::string::index $tablename [expr {$i - 1}]] + } else { + set lastChar "" + } + + #todo - track\count backslashes properly + + set c [tcl::string::index $tablename $i] + if {$c eq "\""} { + if {($lastChar eq "\\")} { + #not strictly correct - we could have had an even number prior-backslash sequence + #the toml spec would have us error out immediately on bsl in bad location - but we're + #trying to parse to unvalidated tomlish + set ctest escq + } else { + set ctest dq + } + } else { + set ctest [string map [list " " sp \t tab] $c] + } + + switch -- $ctest { + . { + switch -exact -- $mode { + preval { + error "tablename_split. dot not allowed - expecting a value" + } + unquoted { + #dot marks end of segment. + if {![tomlish::utils::is_barekey $seg]} { + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + set seg "" + set mode "preval" + } + quoted { + append seg $c + } + litquoted { + append seg $c + } + postval { + #got dot in an expected location + set mode "preval" + } + } + } + dq { + #unescaped dquote + switch -- $mode { + preval { + set mode "quoted" + set seg "\"" + } + unquoted { + #invalid in barekey - but we are after structure only + append seg $c + } + quoted { + append seg $c + if {$normalize} { + lappend segments [::tomlish::utils::unescape_string [tcl::string::range $seg 1 end-1]] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" ;#make sure we only accept a dot or end-of-data now. + } + litquoted { + append seg $c + } + postval { + error "tablename_split. expected whitespace or dot, got double quote. tablename: '$tablename'" + } + } + } + ' { + switch -- $mode { + preval { + append seg $c + set mode "litquoted" + } + unquoted { + #single quote inside e.g o'neill - ultimately invalid - but we pass through here. + append seg $c + } + quoted { + append seg $c + } + litquoted { + append seg $c + #no normalization to do aside from stripping squotes + if {$normalize} { + lappend segments [tcl::string::range $seg 1 end-1] + } else { + lappend segments $seg + } + set seg "" + set mode "postval" + } + postval { + error "tablename_split. expected whitespace or dot, got single quote. tablename: '$tablename'" + } + } + } + sp - tab { + switch -- $mode { + preval - postval { + #ignore + } + unquoted { + #terminates a barekey + lappend segments $seg + set seg "" + set mode "postval" + } + default { + #append to quoted or litquoted + append seg $c + } + } + } + default { + switch -- $mode { + preval { + set mode unquoted + append seg $c + } + postval { + error "tablename_split. Expected a dot separator. got '$c'. tablename: '$tablename'" + } + default { + append seg $c + } + } + } + } + + if {$i == $sLen-1} { + #end of data + ::tomlish::log::debug "End of data: mode='$mode'" + switch -exact -- $mode { + preval { + error "tablename_split. Expected a value after last dot separator. tablename: '$tablename'" + } + unquoted { + if {![tomlish::utils::is_barekey $seg]} { + #e.g toml-test invalid/table/with-pound required to fail for invalid barekey + error "tablename_split. unquoted key segment $seg is not a valid toml key" + } + lappend segments $seg + } + quoted { + error "tablename_split. Expected a trailing double quote. tablename: '$tablename'" + } + litquoted { + error "tablename_split. Expected a trailing single quote. tablename: '$tablename'" + } + postval { + #ok - segment already lappended + } + } + } + } + + #note - we must allow 'empty' quoted strings '' & "" + # (these are 'discouraged' but valid toml keys) + + return $segments + } + + #tablenames (& tablearraynames) may contain irrelevant leading, trailing and interspersed whitespace + # tablenames can be made up of segments delimited by dots. .eg [ a.b . c ] + #trimmed, the tablename becomes {a.b.c} + # A segment may contain whitespace if it is quoted e.g [a . b . "c etc " ] + #ie whitespace is only irrelevant if it's outside a quoted segment + #trimmed, the tablename becomes {a.b."c etc "} + proc tablename_trim {tablename} { + set segments [tablename_split $tablename false] + set trimmed_segments [list] + foreach seg $segments { + lappend trimmed_segments [::string trim $seg " \t"] + } + return [join $trimmed_segments .] + } + + proc get_dottedkey_info {dottedkeyrecord} { + set key_hierarchy [list] + set key_hierarchy_raw [list] + if {[lindex $dottedkeyrecord 0] ne "DOTTEDKEY"} { + error "tomlish::to_dict::get_dottedkey_info error. Supplied list doesn't appear to be a DOTTEDKEY (tag: [lindex $dottedkeyrecord 0])" + } + set compoundkeylist [lindex $dottedkeyrecord 1] + set expect_sep 0 + foreach part $compoundkeylist { + set parttag [lindex $part 0] + if {$parttag eq "WS"} { + continue + } + if {$expect_sep} { + if {$parttag ne "DOTSEP"} { + error "DOTTEDKEY missing dot separator between parts. '$dottedkeyrecord'" + } + set expect_sep 0 + } else { + set val [lindex $part 1] + switch -exact -- $parttag { + KEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw $val + } + DQKEY { + lappend key_hierarchy [::tomlish::utils::unescape_string $val] + lappend key_hierarchy_raw \"$val\" + } + SQKEY { + lappend key_hierarchy $val + lappend key_hierarchy_raw "'$val'" + } + default { + error "tomlish::to_dict::get_dottedkey_info DOTTED key unexpected part '$parttag' - ensure dot separator is between key parts. '$item'" + } + } + set expect_sep 1 + } + } + return [dict create keys $key_hierarchy keys_raw $key_hierarchy_raw] + } + +} + + +tcl::namespace::eval tomlish::app { + #*** !doctools + #[subsection {Namespace tomlish::app}] + #[para] + #[list_begin definitions] + + tcl::namespace::eval argdoc { + proc test_suites {} { + if {[package provide test::tomlish] eq ""} { + return [list] + } + return [test::tomlish::SUITES] + } + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::decoder + @cmd -name tomlish::app::decoder -help\ + "Read toml on stdin until EOF + on error - returns non-zero exit code and writes error to + the errorchannel. + on success - returns zero exit code and writes JSON encoding + of the data to the outputchannel. + This decoder is intended to be compatble with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help\ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc decoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::decoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::decoder] + } + + #fconfigure stdin -encoding utf-8 + fconfigure $ch_input -translation binary + #Just slurp it all - presumably we are not handling massive amounts of data on stdin. + # - even if the input is large, we probably don't gain much (aside from possible memory savings?) by attempting to process input as it arrives. + if {[catch { + set toml [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set j [::tomlish::toml_to_json $toml] + } on error {em} { + puts $ch_error "decoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $j + exit 0 + } + + package require punk::args + punk::args::define { + @id -id ::tomlish::app::encoder + @cmd -name tomlish::app::encoder -help\ + "Read JSON on input until EOF + return non-zero exitcode if JSON data cannot be converted to + a valid TOML representation. + return zero exitcode and TOML data on output if JSON data can + be converted. + This encoder is intended to be compatible with toml-test." + @leaders -min 0 -max 0 + @opts + -help -type none -help \ + "Display this usage message" + -inputchannel -default stdin + -outputchannel -default stdout + -errorchannel -default stderr + @values -min 0 -max 0 + } + proc encoder {args} { + set argd [punk::args::parse $args withid ::tomlish::app::encoder] + set ch_input [dict get $argd opts -inputchannel] + set ch_output [dict get $argd opts -outputchannel] + set ch_error [dict get $argd opts -errorchannel] + if {[dict exists $argd received -help]} { + return [punk::args::usage -scheme info ::tomlish::app::encoder] + } + #review + fconfigure $ch_input -translation binary + if {[catch { + set json [read $ch_input] + }]} { + exit 2 ;#read error + } + try { + set toml [::tomlish::json_to_toml $json] + } on error {em} { + puts $ch_error "encoding failed: '$em'" + exit 1 + } + puts -nonewline $ch_output $toml + exit 0 + } + + punk::args::define { + @dynamic + @id -id ::tomlish::app::test + @cmd -name tomlish::app::test + @leaders + @opts -any 1 + -help -type none -help\ + "Display this usage message + or further info if more args." + -suite -default tests -choices {${[::tomlish::app::argdoc::test_suites]}} + @values -min 0 -max -1 + } + proc test {args} { + package require test::tomlish + set argd [punk::args::parse $args withid ::tomlish::app::test] + set opts [dict get $argd opts] + set values [dict get $argd values] + set received [dict get $argd received] + set solos [dict get $argd solos] + set opt_suite [dict get $opts -suite] + if {[dict exists $received -help] && ![dict exists $received -suite]} { + return [punk::args::usage -scheme info ::tomlish::app::test] + } + + test::tomlish::SUITE $opt_suite + #if {[catch {test::tomlish::SUITE $opt_suite} errM]} { + # puts stderr "Unknown test suite '$opt_suite'. Available suites: [test::tomlish::SUITES]" + # exit 1 + #} + set run_opts [dict remove $opts -suite] + set run_opts [dict remove $run_opts {*}$solos] + set result [test::tomlish::RUN {*}$run_opts {*}$solos {*}$values] + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::app ---}] +} + +proc ::tomlish::appnames {} { + set applist [list] + foreach cmd [info commands ::tomlish::app::*] { + lappend applist [namespace tail $cmd] + } + return $applist +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval tomlish::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace tomlish::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace tomlish::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +if {[info exists ::argc] && $::argc > 0} { + #puts stderr "argc: $::argc args: $::argv" + set arglist $::argv + # -------------- + #make sure any dependant packages that are sourced don't get any commandline args + set ::argv {} + set ::argc 0 + # -------------- + package require punk::args + punk::args::define { + @dynamic + @id -id tomlish::cmdline + @cmd -name tomlish -help\ + "toml encoder/decoder written in Tcl" + @opts -any 1 + -help -type none -help\ + "Display this usage message or more specific + help if further arguments provided." + -app -choices {${[tomlish::appnames]}} + } + try { + set argd [punk::args::parse $arglist withid tomlish::cmdline] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + puts stderr $msg + exit 1 + } + + + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received -help] && ![dict exists $received -app]} { + #only emit cmdline help if -app not supplied as well - otherwise app function can act on -help for more specific help + #puts stdout "Usage: -app where appname one of:[tomlish::appnames]" + puts stdout [punk::args::usage -scheme info tomlish::cmdline] + exit 0 + } + if {![dict exists $received -app]} { + puts stderr [punk::args::usage -scheme error tomlish::cmdline] + exit 1 + } + + set app [dict get $opts -app] + set appnames [tomlish::appnames] + set app_opts [dict remove $opts -app {*}$solos] + try { + set result [tomlish::app::$app {*}$app_opts {*}$solos {*}$values] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + #The validation error should fully describe the issue + #no need for errortrace - keep the output cleaner + puts stderr $msg + exit 1 + } trap {} {msg erroropts} { + #unexpected error - uncaught throw will produce error trace + #todo - a support msg? Otherwise we may as well just leave off this trap. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + if {"-help" in $solos} { + puts stderr $result + exit 1 + } else { + if {$result ne ""} { + puts stdout $result + exit 0 + } + } + + #set opts [dict create] + #set opts [dict merge $opts $::argv] + + #set opts_understood [list -app ] + #if {"-app" in [dict keys $opts]} { + # #Don't vet the remaining opts - as they are interpreted by each app + #} else { + # foreach key [dict keys $opts] { + # if {$key ni $opts_understood} { + # puts stderr "Option '$key' not understood" + # exit 1 + # } + # } + #} + #if {[dict exists $opts -app]} { + # set app [dict get $opts -app] + # set appnames [tomlish::appnames] + # if {$app ni $appnames} { + # puts stderr "app '[dict get $opts -app]' not found. Available apps: $appnames" + # exit 1 + # } + # tomlish::app::$app {*}$opts + #} +} + +## Ready +package provide tomlish [namespace eval tomlish { + variable pkg tomlish + variable version + set version 1.1.5 +}] +return + +#*** !doctools +#[manpage_end] +