diff --git a/src/bootsupport/modules/argparsingtest-0.1.0.tm b/src/bootsupport/modules/argparsingtest-0.1.0.tm index 1ede846b..40366143 100644 --- a/src/bootsupport/modules/argparsingtest-0.1.0.tm +++ b/src/bootsupport/modules/argparsingtest-0.1.0.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application argparsingtest 0.1.0 # Meta platform tcl -# Meta license MIT +# Meta license MIT # @@ Meta End @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_argparsingtest 0 0.1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require argparsingtest] #[keywords module] #[description] @@ -106,7 +106,7 @@ namespace eval argparsingtest { #*** !doctools #[subsection {Namespace argparsingtest}] - #[para] Core API functions for argparsingtest + #[para] Core API functions for argparsingtest #[list_begin definitions] proc test1_ni {args} { @@ -277,8 +277,8 @@ namespace eval argparsingtest { #punk::args is slower than argp - but comparable, and argp doesn't support solo flags proc test1_punkargs {args} { set argd [punk::args::parse $args withdef { - @id -id ::argparsingtest::test1_punkargs - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -298,7 +298,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::test1_punkargs_by_id - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -320,7 +320,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::argparsingtest::test1_punkargs2 - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -334,7 +334,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -3 -default 3 -type integer @values - } + } proc test1_punkargs2 {args} { set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] return [tcl::dict::get $argd opts] @@ -342,9 +342,9 @@ namespace eval argparsingtest { proc test1_punkargs_validate_ansistripped {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs_validate_ansistripped - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string @@ -358,7 +358,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true @values - } $args] + }] return [tcl::dict::get $argd opts] } @@ -387,11 +387,11 @@ namespace eval argparsingtest { package require cmdline #cmdline::getoptions is much faster than typedGetoptions proc test1_cmdline_untyped {args} { - set cmdlineopts_untyped { - {return.arg "string" "return val"} + set cmdlineopts_untyped { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -405,11 +405,11 @@ namespace eval argparsingtest { return [::cmdline::getoptions args $cmdlineopts_untyped $usage] } proc test1_cmdline_typed {args} { - set cmdlineopts_typed { - {return.arg "string" "return val"} + set cmdlineopts_typed { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -465,7 +465,7 @@ namespace eval argparsingtest { #multiline values use first line of each record to determine amount of indent to trim proc test_multiline {args} { set t3 [textblock::frame t3] - set argd [punk::args::get_dict [subst { + set argd [punk::args::parse $args withdef [subst { -template1 -default { ****** * t1 * @@ -476,7 +476,7 @@ namespace eval argparsingtest { * t2 * ******} -template3 -default {$t3} - #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately + #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately -template3b -default { $t3 ----------------- @@ -491,20 +491,20 @@ namespace eval argparsingtest { " -flag -default 0 -type boolean - }] $args] + }]] return $argd } #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] - # return "ok" + # return "ok" #} @@ -524,14 +524,14 @@ namespace eval argparsingtest::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace argparsingtest::lib}] - #[para] Secondary functions that are part of the API + #[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 + # #[para]Description of utility1 + # return 1 #} @@ -549,17 +549,17 @@ namespace eval argparsingtest::lib { namespace eval argparsingtest::system { #*** !doctools #[subsection {Namespace argparsingtest::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide argparsingtest [namespace eval argparsingtest { variable pkg argparsingtest variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/commandstack-0.3.tm b/src/bootsupport/modules/commandstack-0.3.tm index 7884214c..b2561a20 100644 --- a/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/bootsupport/modules/commandstack-0.3.tm @@ -99,8 +99,11 @@ namespace eval commandstack { } } - proc get_stack {command} { + proc get_stack {{command ""}} { variable all_stacks + if {$command eq ""} { + return $all_stacks + } set command [uplevel 1 [list namespace which $command]] if {[dict exists $all_stacks $command]} { return [dict get $all_stacks $command] @@ -116,6 +119,7 @@ namespace eval commandstack { variable all_stacks if {[dict exists $all_stacks $command]} { set stack [dict get $all_stacks $command] + #stack is a list of dicts, 1st entry is token { } set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] if {$posn > -1} { set record [lindex $stack $posn] diff --git a/src/bootsupport/modules/modpod-0.1.3.tm b/src/bootsupport/modules/modpod-0.1.3.tm index 44da4684..540a1696 100644 --- a/src/bootsupport/modules/modpod-0.1.3.tm +++ b/src/bootsupport/modules/modpod-0.1.3.tm @@ -134,12 +134,12 @@ namespace eval modpod { #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::connect -type -default "" @values -min 1 -max 1 path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] + }] catch { punk::lib::showdict $argd ;#heavy dependencies } @@ -168,7 +168,7 @@ namespace eval modpod { } else { #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) set this_pkg_tm_folder [file dirname $modpodpath] if {$connected(type,$modpodpath) ne "unwrapped"} { #Not directly connected to unwrapped version - but may still be redirected there @@ -225,11 +225,15 @@ namespace eval modpod { if {$connected(startdata,$modpodpath) >= 0} { #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { seek $fh $connected(startdata,$modpodpath) start return [list ok $fh] } else { #error "cannot verify tar header" + #try zipfs + if {[info commands tcl::zipfs::mount] ne ""} { + + } } } lpop connected(to) end @@ -262,11 +266,12 @@ namespace eval modpod { return 1 } proc get {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::modpod::get -from -default "" -help "path to pod" - *values -min 1 -max 1 + @values -min 1 -max 1 filename - } $args] + }] set frompod [dict get $argd opts -from] set filename [dict get $argd values filename] @@ -329,7 +334,7 @@ namespace eval modpod::lib { #zipfile is a pure zip at this point - ie no script/exe header proc make_zip_modpod {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::lib::make_zip_modpod -offsettype -default "archive" -choices {archive file} -help\ "Whether zip offsets are relative to start of file or start of zip-data within the file. @@ -340,7 +345,7 @@ namespace eval modpod::lib { @values -min 2 -max 2 zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] + }] set zipfile [dict get $argd values zipfile] set outfile [dict get $argd values outfile] set opt_offsettype [dict get $argd opts -offsettype] @@ -359,7 +364,7 @@ namespace eval modpod::lib { set moddir [file dirname $modfile] set mod_and_ver [file rootname [file tail $modfile]] lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { + if {[file exists $moddir/#modpod-$mod_and_ver]} { source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm } else { #determine module namespace so we can mount appropriately diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index c7207cc0..fd638812 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore { smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ config ::punk::config\ + s ::punk::ns::synopsis\ ] #*** !doctools diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index f671311f..a7fe1047 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu foreach {pt code} $parts { switch -- [llength $codestack] { 0 { - append emit $base$pt$R + append emit $base $pt $R } 1 { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { - append emit $base$pt$R + append emit $base $pt $R set codestack [list] } else { #append emit [lindex $o_codestack 0]$pt if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } default { if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } @@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append emit $code } } - return $emit$R + return [append emit $R] } else { return $base$text$R } diff --git a/src/bootsupport/modules/punk/args-0.1.6.tm b/src/bootsupport/modules/punk/args-0.1.6.tm new file mode 100644 index 00000000..c3bf04b8 --- /dev/null +++ b/src/bootsupport/modules/punk/args-0.1.6.tm @@ -0,0 +1,6400 @@ +# -*- 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.6 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.6] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $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_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + #set val_min $v + dict set F $fid VAL_MIN $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #now cycle through ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set 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]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + #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::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + 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 parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + 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(goodarg) [a+ green strike] + set CLR(goodchoice) [a+ reverse] + 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(goodarg) [a+ strike] + 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 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $form_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $form_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + set id [lindex $tailargs 0] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + + 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-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } 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 + + #JJJJ + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$valmax == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $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 <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $valname_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $validx}] + } + #------------------------------------------ + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + 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 + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -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 + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer 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 + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.6 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/args-0.1.7.tm b/src/bootsupport/modules/punk/args-0.1.7.tm new file mode 100644 index 00000000..b04f4966 --- /dev/null +++ b/src/bootsupport/modules/punk/args-0.1.7.tm @@ -0,0 +1,6458 @@ +# -*- 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.7 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.7] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache [list $optionspecs]] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + + #set opt_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + #set val_min $v + dict set F $fid VAL_MIN $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #now cycle through ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$deflist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set deflist [raw_def $id] + if {$deflist eq ""} { + return + } + return [resolve {*}$deflist] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + variable arg_error_CLR + array set arg_error_CLR {} + set arg_error_CLR(errormsg) [a+ brightred] + set arg_error_CLR(title) "" + set arg_error_CLR(check) [a+ brightgreen] + set arg_error_CLR(solo) [a+ brightcyan] + set arg_error_CLR(choiceprefix) [a+ underline] + set arg_error_CLR(badarg) [a+ brightred] + set arg_error_CLR(goodarg) [a+ green strike] + set arg_error_CLR(goodchoice) [a+ reverse] + set arg_error_CLR(linebase_header) [a+ white] + set arg_error_CLR(cmdname) [a+ brightwhite] + set arg_error_CLR(groupname) [a+ bold] + set arg_error_CLR(ansiborder) [a+ bold] + set arg_error_CLR(ansibase_header) [a+ bold] + set arg_error_CLR(ansibase_body) [a+ white] + variable arg_error_CLR_nocolour + array set arg_error_CLR_nocolour {} + set arg_error_CLR_nocolour(errormsg) [a+ bold] + set arg_error_CLR_nocolour(title) [a+ bold] + set arg_error_CLR_nocolour(check) "" + set arg_error_CLR_nocolour(solo) "" + set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment + set arg_error_CLR_nocolour(goodarg) [a+ strike] + set arg_error_CLR_nocolour(cmdname) [a+ bold] + set arg_error_CLR_nocolour(linebase_header) "" + set arg_error_CLR_nocolour(linebase) "" + set arg_error_CLR_nocolour(ansibase_body) "" + variable arg_error_CLR_info + array set arg_error_CLR_info {} + set arg_error_CLR_info(errormsg) [a+ brightred bold] + set arg_error_CLR_info(title) [a+ brightyellow bold] + set arg_error_CLR_info(check) [a+ brightgreen bold] + set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_info(groupname) [a+ cyan bold] + set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] + set arg_error_CLR_info(ansibase_header) [a+ cyan] + set arg_error_CLR_info(ansibase_body) [a+ white] + variable arg_error_CLR_error + array set arg_error_CLR_error {} + set arg_error_CLR_error(errormsg) [a+ brightred bold] + set arg_error_CLR_error(title) [a+ brightcyan bold] + set arg_error_CLR_error(check) [a+ brightgreen bold] + set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_error(groupname) [a+ cyan bold] + set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] + set arg_error_CLR_error(ansibase_header) [a+ yellow] + set arg_error_CLR_error(ansibase_body) [a+ white] + + + #bas ic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + upvar ::punk::args::arg_error_CLR CLR + + switch -- $scheme { + nocolour { + variable arg_error_CLR_nocolour + array set CLR [array get arg_error_CLR_nocolour + } + info { + variable arg_error_CLR_info + array set CLR [array get arg_error_CLR_info] + } + error { + variable arg_error_CLR_error + array set CLR [array get arg_error_CLR_error] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + #if {"$argdisplay_header$argdisplay_body" eq ""} { + # set is_custom_argdisplay 0 + #} else { + # set is_custom_argdisplay 1 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $form_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $form_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + #unhappy path - not enough options + #review - which form of punk::args::parse? + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + set id [lindex $tailargs 0] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + + 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-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } 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 + + #JJJJ + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$valmax == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $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 <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $valname_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $validx}] + } + #------------------------------------------ + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + 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 + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -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 + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.7 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index aaa595ae..2d949ccf 100644 --- a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates { namespace export * namespace eval class { variable PUNKARGS - #set argd [punk::args::get_dict { - # @id -id "::punk::cap::handlers::templates::class::api folders" - # -startdir -default "" - # @values -max 0 - #} $args] - lappend PUNKARGS [list { - @id -id "::punk::cap::handlers::templates::class::api folders" - -startdir -default "" - @values -max 0 - }] + #lappend PUNKARGS [list { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #}] oo::class create api { #return a dict keyed on folder with source pkg as value @@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates { set cname [string map {. _} $capname] set capabilityname $capname } + set class_ns [uplevel 1 [list namespace current]] + + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + @cmd -name "punk::cap::handlers::templates::class::api folders" + -startdir -default "" -help\ + "Defaults to CWD if not supplied" + @values -max 0 + }] method folders {args} { #puts "--folders $args" - set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] + set argd [punk::args::parse $args withid "[self class] folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates { } return $folderdict } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" + @cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\ + "" + @opts -anyopts 1 + #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here + -startdir -default "" + @values -maxvalues -1 + }] method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" - @opts -anyopts 1 - #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here - -startdir -default "" - @values -maxvalues -1 - } $args] + + set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"] + set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { @@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates { my _get_itemdict {*}$arglist } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" + @cmd -name _get_itemdict + @opts -anyopts 0 + -startdir -default "" + -templatefolder_subdir -optional 0 + -command_get_items_from_base -optional 0 + -command_get_item_name -optional 0 + -not -default "" -multiple 1 + @values -maxvalues -1 + globsearches -default * -multiple 1 + }] + #shared algorithm for get_itemdict_* methods #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" - @cmd -name _get_itemdict - @opts -anyopts 0 - -startdir -default "" - -templatefolder_subdir -optional 0 - -command_get_items_from_base -optional 0 - -command_get_item_name -optional 0 - -not -default "" -multiple 1 - @values -maxvalues -1 - globsearches -default * -multiple 1 - } $args] + set argd [punk::args::parse $args withid "[self class] _get_itemdict"] + set opts [dict get $argd opts] set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results #puts stderr "=-=============>globsearches:$globsearches" diff --git a/src/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index e278d99f..3a5f25b0 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/modules/punk/config-0.1.tm @@ -44,8 +44,11 @@ tcl::namespace::eval punk::config { @values -min 0 -max 0 }] proc dir {args} { + #set be_quiet [dict exists $received -quiet] if {"-quiet" in $args} { - set be_quiet [dict exists $received -quiet] + set be_quiet 1 + } else { + set be_quiet 0 } set was_noisy 0 @@ -445,6 +448,7 @@ tcl::namespace::eval punk::config { "Get configuration values from a config. Accepts globs eg XDG*" @leaders -min 1 -max 1 + #todo - load more whichconfig choices? whichconfig -type string -choices {config startup-configuration running-configuration} @values -min 0 -max -1 globkey -type string -default * -optional 1 -multiple 1 @@ -526,18 +530,23 @@ tcl::namespace::eval punk::config { error "setting value not implemented" } - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::config::show - @cmd -name punk::config::get -help\ - "Display configuration values from a config. - Accepts globs eg XDG*" - @leaders -min 1 -max 1 - }\ - {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ - "@values -min 0 -max -1"\ - {${[punk::args::resolved_def -types values ::punk::config::get]}}\ - ] + namespace eval argdoc { + set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}} + set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}} + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${$DYN_GET_LEADERS}}\ + "@values -min 0 -max -1"\ + {${$DYN_GET_VALUES}}\ + ] + } proc show {args} { #todo - tables for console set configrecords [punk::config::get {*}$args] @@ -568,7 +577,7 @@ tcl::namespace::eval punk::config { toconfig -help\ "running or startup or file name (not fully implemented)" } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::parse $args withdef $argdef] set fromconfig [dict get $argd values fromconfig] set toconfig [dict get $argd values toconfig] set fromconfig [string map {-config ""} $fromconfig] diff --git a/src/bootsupport/modules/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm index adb47eff..7d1375d7 100644 --- a/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -562,13 +562,13 @@ namespace eval punk::du { proc Get_attributes_from_iteminfo {args} { variable win_reparse_tags_by_int - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::Get_attributes_from_iteminfo -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" - } $args] + }] set opts [dict get $argd opts] set iteminfo [dict get $argd values iteminfo] set opt_debug [dict get $opts -debug] @@ -621,14 +621,14 @@ namespace eval punk::du { proc attributes_twapi {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::attributes_twapi -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" - } $args] + }] set opts [dict get $argd opts] set path [dict get $argd values path] set opt_detail [dict get $opts -detail] diff --git a/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/bootsupport/modules/punk/fileline-0.1.0.tm index ca222524..86126a5c 100644 --- a/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib { } proc range_boundaries {start end chunksizes args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { -offset -default 0 - } $args] + }] lassign [dict values $argd] leaders opts remainingargs } diff --git a/src/bootsupport/modules/punk/lib-0.1.0.tm b/src/bootsupport/modules/punk/lib-0.1.0.tm deleted file mode 100644 index fea9534f..00000000 --- a/src/bootsupport/modules/punk/lib-0.1.0.tm +++ /dev/null @@ -1,1472 +0,0 @@ -# -*- 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::lib 0.1.0 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.1.0] -#[copyright "2024"] -#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk library}] [comment {-- Description at end of page heading --}] -#[require punk::lib] -#[keywords module utility lib] -#[description] -#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. -#[para]The base set includes string and math functions but has no specific theme - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::lib -#[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl -#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. -#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::lib -#[list_begin itemized] - -package require Tcl 8.6 -#*** !doctools -#[item] [package {Tcl 8.6}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::lib::class { - #*** !doctools - #[subsection {Namespace punk::lib::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::lib { - namespace export * - #variable xyz - - #*** !doctools - #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib - #[list_begin definitions] - - - - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - - proc K {x y} {return $x} - #*** !doctools - #[call [fun K] [arg x] [arg y]] - #[para]The K-combinator function - returns the first argument, x and discards y - #[para]see [uri https://wiki.tcl-lang.org/page/K] - #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. - - proc hex2dec {args} { - #*** !doctools - #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] - #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values - #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 - #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. - #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 - #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 - - set list_largeHex [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" - } - set defaults [dict create\ - -validate 1\ - -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ - ] - set known_opts [dict keys $defaults] - set fullopts [dict create] - dict for {k v} $argopts { - dict set fullopts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v - } - set opts [dict merge $defaults $fullopts] - # -- --- --- --- - set opt_validate [dict get $opts -validate] - set opt_empty [dict get $opts -empty_as_hex] - # -- --- --- --- - - set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map [list _ ""] [string trim $h]}] - if {$opt_validate} { - #Note appended F so that we accept list of empty strings as per the documentation - if {![string is xdigit -strict [join $list_largeHex ""]F ]} { - error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" - } - } - if {![string is xdigit -strict [string map [list _ ""] $opt_empty]]} { - #mapping empty string to a value destroys any advantage of -scanonly - #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] - if {[lsearch $list_largeHex ""] >=0} { - error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" - } - } else { - set opt_empty [string trim [string map [list _ ""] $opt_empty]] - if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] - set nonempty_head [lrange $list_largeHex 0 $first_empty-1] - set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] - } - - proc dec2hex {args} { - #*** !doctools - #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] - #[para]Convert a list of decimal integers to a list of hex values - #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. - #[para] -case upper|lower determines the case of the hex letters in the output - set list_decimals [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" - } - set defaults [dict create\ - -width 1\ - -case upper\ - -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ - ] - set known_opts [dict keys $defaults] - set fullopts [dict create] - dict for {k v} $argopts { - dict set fullopts [tcl::prefix match -message "options for [namespace current]::dec2hex. Unexpected option" $known_opts $k] $v - } - set opts [dict merge $defaults $fullopts] - # -- --- --- --- - set opt_width [dict get $opts -width] - set opt_case [dict get $opts -case] - set opt_empty [dict get $opts -empty_as_decimal] - # -- --- --- --- - - - set resultlist [list] - if {[string tolower $opt_case] eq "upper"} { - set spec X - } elseif {[string tolower $opt_case] eq "lower"} { - set spec x - } else { - error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" - } - set fmt "%${opt_width}.${opt_width}ll${spec}" - - set list_decimals [lmap d $list_decimals[unset list_decimals] {string map [list _ ""] [string trim $d]}] - if {![string is digit -strict [string map [list _ ""] $opt_empty]]} { - if {[lsearch $list_decimals ""] >=0} { - error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" - } - } else { - set opt_empty [string map [list _ ""] $opt_empty] - if {[set first_empty [lsearch $list_decimals ""]] >= 0} { - set nonempty_head [lrange $list_decimals 0 $first_empty-1] - set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] - } - - proc log2 x "expr {log(\$x)/[expr log(2)]}" - #*** !doctools - #[call [fun log2] [arg x]] - #[para]log base2 of x - #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time - #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) - - proc logbase {b x} { - #*** !doctools - #[call [fun logbase] [arg b] [arg x]] - #[para]log base b of x - #[para]This function uses expr's natural log and the change of base division. - #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 - #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 - expr {log($x)/log($b)} - } - proc factors {x} { - #*** !doctools - #[call [fun factors] [arg x]] - #[para]Return a sorted list of the positive factors of x where x > 0 - #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* - #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors - #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions - #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers - #[para]Comparisons were done with some numbers below 17 digits long - #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. - #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers - #but has the disadvantage of being slower for 'small' numbers and using more memory. - #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x - #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py - #[para] In other mathematical contexts zero may be considered not to divide anything. - set factors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {($x % $j) == 0} { - lappend factors $j [expr {$x / $j}] - } - incr j - } - lappend factors $x - return [lsort -unique -integer $factors] - } - proc oddFactors {x} { - #*** !doctools - #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order - set j 2 - set max [expr {sqrt($x)}] - set factors [list 1] - while {$j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 != 0} { - if {$other ni $factors} { - lappend factors $other - } - } - if {$j % 2 != 0} { - if {$j ni $factors} { - lappend factors $j - } - } - } - incr j - } - return [lsort -integer -increasing $factors] - } - proc greatestFactorBelow {x} { - #*** !doctools - #[call [fun greatestFactorBelow] [arg x]] - #[para]Return the largest factor of x excluding itself - #[para]factor functions can be useful for console layout calculations - #[para]See Tcllib math::numtheory for more extensive implementations - if {$x % 2 == 0 || $x == 0} { - return [expr {$x / 2}] - } - set j 3 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {$x % $j == 0} { - return [expr {$x / $j}] - } - incr j 2 - } - return 1 - } - proc greatestOddFactorBelow {x} { - #*** !doctools - #[call [fun greatestOddFactorBelow] [arg x]] - #[para]Return the largest odd integer factor of x excluding x itself - if {$x %2 == 0} { - return [greatestOddFactor $x] - } - set j 3 - #dumb brute force - time taken to compute is wildly variable on big numbers - #todo - use a (memoized?) generator of primes to reduce the search space - #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. - set god 1 - set max [expr {sqrt($x)}] - while { $j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 == 0} { - set god $j - } else { - set god [expr {$x / $j}] - #lowest j - so other side must be highest - break - } - } - incr j 2 - } - return $god - } - proc greatestOddFactor {x} { - #*** !doctools - #[call [fun greatestOddFactor] [arg x]] - #[para]Return the largest odd integer factor of x - #[para]For an odd value of x - this will always return x - if {$x % 2 != 0 || $x == 0} { - return $x - } - set r [expr {$x / 2}] - while {$r % 2 == 0} { - set r [expr {$r / 2}] - } - return $r - } - proc gcd {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the greatest common divisor of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para]Graphical use: - #[para]An a by b rectangle can be covered with square tiles of side-length c, - #[para]only if c is a common divisor of a and b - - # - # Apply Euclid's good old algorithm - # - if { $n > $m } { - set t $n - set n $m - set m $t - } - - while { $n > 0 } { - set r [expr {$m % $n}] - set m $n - set n $r - } - - return $m - } - proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] - set gcd [gcd $n $m] - return [expr {$n*$m/$gcd}] - } - proc commonDivisors {x y} { - #*** !doctools - #[call [fun commonDivisors] [arg x] [arg y]] - #[para]Return a list of all the common factors of x and y - #[para](equivalent to factors of their gcd) - return [factors [gcd $x $y]] - } - - #experimental only - there are better/faster ways - proc sieve n { - set primes [list] - if {$n < 2} {return $primes} - set nums [dict create] - for {set i 2} {$i <= $n} {incr i} { - dict set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i} - lappend primes $next - dict for {next -} $nums break - } - return [concat $primes [dict keys $nums]] - } - proc sieve2 n { - set primes [list] - if {$n < 2} {return $primes} - set nums [dict create] - for {set i 2} {$i <= $n} {incr i} { - dict set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i} - lappend primes $next - #dict for {next -} $nums break - set next [lindex $nums 0] - } - return [concat $primes [dict keys $nums]] - } - - proc hasglobs {str} { - #*** !doctools - #[call [fun hasglobs] [arg str]] - #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] - #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. - regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving - } - - proc trimzero {number} { - #*** !doctools - #[call [fun trimzero] [arg number]] - #[para]Return number with left-hand-side zeros trimmed off - unless all zero - #[para]If number is all zero - a single 0 is returned - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - proc substring_count {str substring} { - #*** !doctools - #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of substring - - #faster than lsearch on split for str of a few K - if {$substring eq ""} {return 0} - set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] - return [expr {$occurrences / [string length $substring]}] - } - - proc dict_merge_ordered {defaults main} { - #*** !doctools - #[call [fun dict_merge_ordered] [arg defaults] [arg main]] - #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. - #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. - #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. - - #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values - return [dict merge [dict merge $main $defaults] $main] - } - - proc askuser {question} { - #*** !doctools - #[call [fun askuser] [arg question]] - #[para]A basic utility to read an answer from stdin - #[para]The prompt is written to the terminal and then it waits for a user to type something - #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. - #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. - #[para](Generic terminal raw vs linemode detection not yet present) - #[para]The user must hit enter to submit the response - #[para]The return value is the string if any that was typed prior to hitting enter. - #[para]The question argument can be manually colourised using the various punk::ansi funcitons - #[example_begin] - # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] - # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { - # puts "Proceeding" - # } else { - # puts "Cancelled by user" - # } - #[example_end] - puts stdout $question - flush stdout - set stdin_state [fconfigure stdin] - if {[catch { - package require punk::console - set console_raw [set ::punk::console::is_raw] - } err_console]} { - #assume normal line mode - set console_raw 0 - } - try { - fconfigure stdin -blocking 1 - if {$console_raw} { - punk::console::disableRaw - set answer [gets stdin] - punk::console::enableRaw - } else { - set answer [gets stdin] - } - } finally { - fconfigure stdin -blocking [dict get $stdin_state -blocking] - } - return $answer - } - - #e.g linesort -decreasing $data - proc linesort {args} { - #*** !doctools - #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] - #[para]Sort lines in textblock - #[para]Returns another textblock with lines sorted - #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique - if {[llength $args] < 1} { - error "linesort missing lines argument" - } - set lines [lindex $args end] - set opts [lrange $args 0 end-1] - #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts - list_as_lines [lsort {*}$opts [linelist $lines]] - } - - proc list_as_lines {args} { - #*** !doctools - #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] - #[para]This simply joines the elements of the list with -joinchar - #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines - #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. - if {[set eop [lsearch $args --]] == [llength $args]-2} { - #end-of-opts not really necessary - except for consistency with lines_as_list - set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] - } - if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { - set joinchar [lindex $args 1] - set lines [lindex $args 2] - } elseif {[llength $args] == 1} { - set joinchar "\n" - set lines [lindex $args 0] - - } else { - error "list_as_lines usage: list_as_lines ?-joinchar ? " - } - return [join $lines $joinchar] - } - proc list_as_lines2 {args} { - #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible - lassign [dict values [punk::lib::opts_values -minvalues 1 -maxvalues 1 { - -joinchar -default \n - } $args]] opts values - return [join [dict get $values 0] [dict get $opts -joinchar]] - } - - proc lines_as_list {args} { - #*** !doctools - #[call [fun lines_as_list] [opt {option value ...}] [arg text]] - #[para]Returns a list of possibly trimmed lines depeding on options - #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf - #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements - - #The underlying function linelist has the validation code which gives nicer usage errors. - #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error - #..because we don't know what to say if there are odd numbers of args - #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work - #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway - - if {[lsearch $args "--"] == [llength $args]-2} { - set opts [lrange $args 0 end-2] - } else { - set opts [lrange $args 0 end-1] - } - #set opts [dict merge {-block {}} $opts] - set bposn [lsearch $opts -block] - if {$bposn < 0} { - set opts {-block {}} - } - set text [lindex $args end] - tailcall linelist {*}$opts $text - } - #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds - proc lines_as_list2 {args} { - #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults - #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc - #we don't have to decide what is an opt vs a value - #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) - lassign [dict values [punk::lib::opts_values -anyopts 1 { - -block -default {} - } $args]] opts valuedict - tailcall linelist {*}$opts {*}[dict values $valuedict] - } - - # important for pipeline & match_assign - # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? - # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace - proc linelist {args} { - #puts "---->linelist '$args'" - set usage "linelist ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map [list \r\n \n] $text] ;#review - option? - - set arglist [lrange $args 0 end-1] - set defaults [dict create\ - -block {trimhead1 trimtail1}\ - -line {}\ - -commandprefix ""\ - -ansiresets 1\ - ] - dict for {o v} $arglist { - if {$o ni {-block -line -commandprefix -ansiresets}} { - error "linelist: Unrecognized option '$o' usage:$usage" - } - } - set opts [dict merge $defaults $arglist] - # -- --- --- --- --- --- - set opt_block [dict get $opts -block] - set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] - foreach bo $opt_block { - if {$bo ni $known_blockopts} { - error "linelist: unknown -block option value: $bo known values: $known_blockopts" - } - } - #normalize certain combos - if {[set posn [lsearch $opt_block trimhead1]] >=0 && "trimhead" in $opt_block} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {[set posn [lsearch $opt_block trimtail1]] >=0 && "trimtail" in $opt_block} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimall" in $opt_block} { - #no other block options make sense in combination with this - set opt_block [list "trimall"] - } - - #TODO - if {"triminner" in $opt_block } { - error "linelist -block triminner not implemented - sorry" - } - - # -- --- --- --- --- --- - set opt_line [dict get $opts -line] - set known_lineopts [list trimline trimleft trimright] - foreach lo $opt_line { - if {$lo ni $known_lineopts} { - error "linelist: unknown -line option value: $lo known values: $known_lineopts" - } - } - #normalize trimleft trimright combo - if {"trimleft" in $opt_line && "trimright" in $opt_line} { - set opt_line [list "trimline"] - } - # -- --- --- --- --- --- - set opt_commandprefix [dict get $opts -commandprefix] - # -- --- --- --- --- --- - set linelist [list] - set nlsplit [split $text \n] - if {![llength $opt_line]} { - set linelist $nlsplit - #lappend linelist {*}$nlsplit - } else { - foreach ln $nlsplit { - #already normalized trimleft+trimright to trimline - if {"trimline" in $opt_line} { - lappend linelist [string trim $ln] - } elseif {"trimleft" in $opt_line} { - lappend linelist [string trimleft $ln] - } elseif {"trimright" in $opt_line} { - lappend linelist [string trimright $ln] - } - } - } - - if {"collateempty" in $opt_block} { - set inputlist $linelist[set linelist [list]] - set last "-" - foreach input $inputlist { - if {$input ne ""} { - lappend linelist $input - set last "-" - } else { - if {$last ne ""} { - lappend linelist "" - } - set last "" - } - } - } - - if {"trimall" in $opt_block} { - set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] - } else { - set start 0 - if {"trimhead" in $opt_block} { - set idx 0 - set lastempty -1 - foreach ln $linelist { - if {[lindex $linelist $idx] ne ""} { - break - } else { - set lastempty $idx - } - incr idx - } - if {$lastempty >=0} { - set start [expr {$lastempty +1}] - } - } - set linelist [lrange $linelist $start end] - - if {"trimtail" in $opt_block} { - set revlinelist [lreverse $linelist][set linelist {}] - set i 0 - foreach ln $revlinelist { - if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] - break - } - incr i - } - } - - # --- --- - set start 0 - set end "end" - if {"trimhead1" in $opt_block} { - if {[lindex $linelist 0] eq ""} { - set start 1 - } - } - if {"trimtail1" in $opt_block} { - if {[lindex $linelist end] eq ""} { - set end "end-1" - } - } - set linelist [lrange $linelist $start $end] - } - - if {[llength $opt_commandprefix]} { - set transformed [list] - foreach ln $linelist { - lappend transformed [{*}$opt_commandprefix $ln] - } - set linelist $transformed - } - - return $linelist - } - - #maintenance - take over from punk::args - or put back in punk::args once fixed to support pipeline argument order - #possible improvements - after the 1st call, replace the callsite in the calling proc with an inline script to process and validate the arguments as specified in optionspecs - #This would require a tcl parser .. and probably lots of other work - #It would also probably only be practical if there are no dynamic entries in the optionspecs. An option for opts_values to indicate the caller wants this optimisation would probably be best. - - #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 opts_values {args} { - #*** !doctools - #[call [fun opts_values] [opt {option value...}] [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 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 - #[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 - #[list_end] - #[para] - - #consider line-processing example below for we need info complete to determine record boundaries - #punk::lib::opt_values { - # -opt1 -default {} - # -opt2 -default { - # etc - # } -multiple 1 - #} $args - - #-- cannot be used to allow opts_values itself to accept rawargs as separate values - so it doesn't serve much purpose other than as an indicator of intention - #For consistency we support it anyway. - #we have to be careful with end-of-options flag -- - #It may legitimately be the only value in the rawargs list (which is a bit odd - but possible) or it may occur immediately before optionspecs and rawargs - #if there is more than one entry in rawargs - we won't find it anyway - so that's ok - set eopts_posn [lsearch $args --] - if {$eopts_posn == ([llength $args]-1)} { - #sole argument in rawargs - not the one we're looking for - set eopts_posn -1 - } - if {$eopts_posn >= 0} { - set ov_opts [lrange $args 0 $eopts_posn-1] - set ov_vals [lrange $args $eopts_posn+1 end] - } else { - set ov_opts [lrange $args 0 end-2] - set ov_vals [lrange $args end-1 end] - } - if {[llength $ov_vals] < 2 || [llength $ov_opts] %2 != 0} { - error "opts_args wrong # args: should be opts_values ?opt val?... optionspecs rawargs_as_list - } - set optionspecs [lindex $ov_vals 0] - set optionspecs [string map [list \r\n \n] $optionspecs] - - set rawargs [lindex $ov_vals 1] - - set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -ARGTYPE] - set optspec_defaults [dict create\ - -optional 1\ - -allow_ansi 1\ - -validate_without_ansi 0\ - -strip_ansi 0\ - -nocase 0\ - ] - set required_opts [list] - set required_vals [list] - set arg_info [dict create] - set defaults_dict_opts [dict create] - set defaults_dict_values [dict create] - #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end - set value_names [list] - - set records [list] - set linebuild "" - foreach rawline [split $optionspecs \n] { - set recordsofar [string cat $linebuild $rawline] - if {![info complete $recordsofar]} { - append linebuild [string trimleft $rawline] \n - } else { - lappend records [string cat $linebuild $rawline] - set linebuild "" - } - } - - foreach ln $records { - set trimln [string trim $ln] - if {$trimln eq "" || [string index $trimln 0] eq "#"} { - continue - } - set argname [lindex $trimln 0] - set argspecs [lrange $trimln 1 end] - if {[llength $argspecs] %2 != 0} { - error "punk::lib::opts_values - bad optionspecs line for argument '$argname' Remaining items on line must be in paired option-value format - received '$argspecs'" - } - if {[string match -* $argname]} { - dict set argspecs -ARGTYPE option - set is_opt 1 - } else { - dict set argspecs -ARGTYPE value - lappend value_names $argname - set is_opt 0 - } - dict for {spec specval} $argspecs { - if {$spec ni $known_argspecs} { - error "punk::lib::opts_values - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" - } - } - set argspecs [dict merge $optspec_defaults $argspecs] - dict set arg_info $argname $argspecs - if {![dict get $argspecs -optional]} { - if {$is_opt} { - lappend required_opts $argname - } else { - lappend required_vals $argname - } - } - if {[dict exists $arg_info $argname -default]} { - if {$is_opt} { - dict set defaults_dict_opts $argname [dict get $arg_info $argname -default] - } else { - dict set defaults_dict_values $argname [dict get $arg_info $argname -default] - } - } - } - - #puts "--> [info frame -2] <--" - set cmdinfo [dict get [info frame -2] cmd] - #we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work - #hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc - #we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) - set caller [regexp -inline {\S+} $cmdinfo] - - #if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" - if {$caller eq "namespace"} { - set caller "punk::lib::opts_values called from namespace" - } - - # ------------------------------ - if {$caller ne "punk::lib::opts_values"} { - #1) check our caller's call to us - recursive version - perhaps more elegant to eat our own dogfood - but maybe too much overhead for a script-based args processor which is already quite heavy :/ - #lassign [punk::lib::opts_values "-anyopts -default 0 -type integer\n -minvalues -default 0 -type integer\n -maxvalues -default -1 -type integer" $args] _o ownopts _v ownvalues - #if {[dict size $ownvalues] != 2} { - # error "punk::lib::opts_values expected: a multiline text block of option-specifications, a list of args and at most three option pairs -minvalues , -maxvalues , -anyopts true|false - got extra arguments: '$ownvalues'" - #} - #set opt_minvalues [dict get $ownopts -minvalues] - #set opt_maxvalues [dict get $ownopts -maxvalues] - #set opt_anyopts [dict get $ownopts -anyopts] - - #2) Quick and dirty - but we don't need much validation - set defaults [dict create\ - -minvalues 0\ - -maxvalues -1\ - -anyopts 0\ - ] - dict for {k v} $ov_opts { - if {$k ni {-minvalues -maxvalues -anyopts}} { - error "punk::lib::opts_values unrecognised option $k. Known values [dict keys $defaults]" - } - if {![string is integer -strict $v]} { - error "punk::lib::opts_values argument $k must be of type integer" - } - } - set ov_opts [dict merge $defaults $ov_opts] - set opt_minvalues [dict get $ov_opts -minvalues] - set opt_maxvalues [dict get $ov_opts -maxvalues] - set opt_anyopts [dict get $ov_opts -anyopts] - } else { - #don't recurse ie don't check our own args if we called ourself - set opt_minvalues 2 - set opt_maxvalues 2 - set opt_anyopts 0 - } - # ------------------------------ - - if {[set eopts [lsearch $rawargs "--"]] >= 0} { - set values [lrange $rawargs $eopts+1 end] - set arglist [lrange $rawargs 0 $eopts-1] - } else { - if {[lsearch $rawargs -*] >= 0} { - #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex - set i 0 - foreach {k v} $rawargs { - if {![string match -* $k]} { - break - } - if {$i+1 >= [llength $rawargs]} { - #no value for last flag - error "bad options for $caller. No value supplied for last option $k" - } - incr i 2 - } - set arglist [lrange $rawargs 0 $i-1] - set values [lrange $rawargs $i end] - } else { - set arglist [list] - set values $rawargs ;#no -flags detected - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange $value_names 0 end-1] { - if {[dict exists $arg_info $valname -multiple ]} { - error "bad key -multiple on argument spec for '$valname'. Only the last value argument specification can be marked -multiple" - } - } - set values_dict [dict create] - set validx 0 - set in_multiple "" - foreach valname $value_names val $values { - if {$validx+1 > [llength $values]} { - break - } - if {$valname ne ""} { - if {[dict exists $arg_info $valname -multiple] && [dict get $arg_info $valname -multiple]} { - dict lappend values_dict $valname $val - set in_multiple $valname - } else { - dict set values_dict $valname $val - } - } else { - if {$in_multiple ne ""} { - dict lappend values_dict $in_multiple $val - } else { - dict set values_dict $validx $val - } - } - incr validx - } - - if {$opt_maxvalues == -1} { - #only check min - if {[llength $values] < $opt_minvalues} { - error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" - } - } else { - if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { - if {$opt_minvalues == $opt_maxvalues} { - error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" - } else { - error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" - } - } - } - #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 will 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 - set argnamespresent [dict keys $arglist] - foreach r $required_opts { - if {$r ni $argspresent} { - error "Required option missing for $caller. '$r' is marked with -optional false - so must be present in its full-length form" - } - } - set valuenamespresent [dict keys $values_dict] - foreach r $required_vals { - if {$r ni $valuenamespresent} { - error "Required value missing for $caller. '$r' is marked with -optional false - so must be present" - } - } - if {!$opt_anyopts} { - set checked_args [dict create] - for {set i 0} {$i < [llength $arglist]} {incr i} { - #allow this to error out with message indicating expected flags - set val [lindex $arglist $i+1] - set fullopt [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $arg_info] [lindex $arglist $i]] - if {[dict exists $arg_info $fullopt -multiple] && [dict get $arg_info $fullopt -multiple]} { - dict lappend checked_args $fullopt $val - } else { - dict set checked_args $fullopt $val - } - incr i ;#skip val - } - } else { - #still need to use tcl::prefix match to normalize - but don't raise an error - set checked_args [dict create] - dict for {k v} $arglist { - if {![catch {tcl::prefix::match [dict keys $arg_info] $k} fullopt]} { - if {[dict exists $arg_info $fullopt -multiple] && [dict get $arg_info $fullopt -multiple]} { - dict lappend checked_args $fullopt $v - } else { - dict set checked_args $fullopt $v - } - } else { - #opt was unspecified - dict set checked_args $k $v - } - } - } - set opts [dict merge $defaults_dict_opts $checked_args] - #assert - checked_args keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - set values [dict merge $defaults_dict_values $values_dict] - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [concat $opts $values] - set combined_defaults [concat $defaults_dict_values $defaults_dict_opts] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - dict for {o v} $opts_and_values { - if {[dict exists $arg_info $o -multiple] && [dict get $arg_info $o -multiple]} { - set vlist $v - } else { - set vlist [list $v] - } - - if {[dict exists $arg_info $o -validate_without_ansi] && [dict get $arg_info $o -validate_without_ansi]} { - set validate_without_ansi 1 - package require punk::ansi - } else { - set validate_without_ansi 0 - } - if {[dict exists $arg_info $o -allow_ansi] && [dict get $arg_info $o -allow_ansi]} { - set allow_ansi 1 - } else { - #ironically - we need punk::ansi to detect and disallow - but we don't need it if ansi is allowed - package require punk::ansi - set allow_ansi 0 - } - if {!$allow_ansi} { - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $o for $caller contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - - set vlist_check [list] - foreach e $vlist { - if {$validate_without_ansi} { - lappend vlist_check [punk::ansi::stripansi $e] - } else { - lappend vlist_check $e - } - } - - set is_default 0 - foreach e $vlist e_check $vlist_check { - if {[dict exists $combined_defaults $o] && ($e_check eq [dict get $combined_defaults $o])} { - incr is_default - } - } - if {$is_default eq [llength $vlist]} { - set is_default true - } - #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. - if {!$is_default} { - if {[dict exists $arg_info $o -type]} { - set type [dict get $arg_info $o -type] - if {[string tolower $type] in {int integer double}} { - if {[string tolower $type] in {int integer}} { - foreach e $vlist e_check $vlist_check { - if {![string is integer -strict $e_check]} { - error "Option $o for $caller requires type 'integer'. Received: '$e'" - } - } - } elseif {[string tolower $type] in {double}} { - foreach e $vlist e_check $vlist_check { - if {![string is double -strict $e_check]} { - error "Option $o for $caller requires type 'double'. Received: '$e'" - } - } - } - - #todo - small-value double comparisons with error-margin? review - if {[dict exists $arg_info $o -range]} { - lassign [dict get $arg_info $o -range] low high - foreach e $vlist e_check $vlist_check { - if {$e_check < $low || $e_check > $high} { - error "Option $o for $caller must be between $low and $high. Received: '$e'" - } - } - } - } elseif {[string tolower $type] in {bool boolean}} { - foreach e $vlist e_check $vlist_check { - if {![string is boolean -strict $e_check]} { - error "Option $o for $caller requires type 'boolean'. Received: '$e'" - } - } - } elseif {[string tolower $type] in {alnum alpha ascii control digit graph lower print punct space upper wordchar xdigit}} { - foreach e $vlist e_check $vlist_check { - if {![string is [string tolower $type] $e_check]} { - error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e'" - } - } - } elseif {[string tolower $type] in {file directory existingfile existingdirectory}} { - foreach e $vlist e_check $vlist_check { - if {!([string length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} { - error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which doesn't look like it could be a file or directory" - } - } - if {[string tolower $type] in {existingfile}} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not an existing file" - } - } - } elseif {[string tolower $type] in {existingdirectory}} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not an existing directory" - } - } - } - } elseif {[string tolower $type] in {char character}} { - foreach e $vlist e_check $vlist_check { - if {[string length != 1]} { - error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not a single character" - } - } - } - } - if {[dict exists $arg_info $o -choices]} { - set choices [dict get $arg_info $o -choices] - set nocase [dict get $arg_info $o -nocase] - foreach e $vlist e_check $vlist_check { - if {$nocase} { - set casemsg "(case insensitive)" - set choices_test [string tolower $choices] - set v_test [string tolower $e_check] - } else { - set casemsg "(case sensitive)" - set v_test $e_check - set choices_test $choices - } - if {$v_test ni $choices_test} { - error "Option $o for $caller must be one of the listed values $choices $casemsg. Received: '$e'" - } - } - } - } - if {[dict exists $arg_info $o -strip_ansi] && [dict get $arg_info $o -strip_ansi]} { - set stripped_list [list] - foreach e $vlist { - lappend stripped_list [punk::ansi::stripansi $e] - } - if {[dict exists $arg_info $o -multiple] && [dict get $arg_info $o -multiple]} { - if {[dict get $arg_info $o -ARGTYPE] eq "option"} { - dict set opts $o $stripped_list - } else { - dict set values $o $stripped_list - } - } else { - if {[dict get $arg_info $o -ARGTYPE] eq "option"} { - dict set opts $o [lindex $stripped_list 0] - } else { - dict set values [lindex $stripped_list 0] - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - return [dict create opts $opts values $values] - } - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#todo - way to generate 'internal' docs separately? -#*** !doctools -#[section Internal] -namespace eval punk::lib::system { - #*** !doctools - #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API - #[list_begin definitions] - - proc mostFactorsBelow {n} { - ##*** !doctools - #[call [fun mostFactorsBelow] [arg n]] - #[para]Find the number below $n which has the greatest number of factors - #[para]This will get slow quickly as n increases (100K = 1s+ 2024) - set most 0 - set mostcount 0 - for {set i 1} {$i < $n} {incr i} { - set fc [llength [punk::lib::factors $i]] - if {$fc > $mostcount} { - set most $i - set mostcount $fc - } - } - return [list number $most numfactors $mostcount] - } - proc factorCountBelow_punk {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [punk::lib::factors $i]] - } - return $tally - } - proc factorCountBelow_numtheory {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) - package require math::numtheory - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [math::numtheory::factors $i]] - } - return $tally - } - - proc factors2 {x} { - ##*** !doctools - #[call [fun factors2] [arg x]] - #[para]Return a sorted list of factors of x - #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. - set smallfactors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j < $max} { - if {($x % $j) == 0} { - lappend smallfactors $j - lappend largefactors [expr {$x / $j}] - } - incr j - } - #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop - if {($x % $j) == 0} { - if {$j == ($x / $j)} { - lappend smallfactors $j - } - } - return [concat $smallfactors [lreverse $largefactors] $x] - } - - #important - used by punk::repl - proc incomplete {partial} { - #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - #puts stderr "-->$clist<--" - set waiting [list ""] - set innerpartials [list ""] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } ;# set escaped 0 at end - set p [lindex $innerpartials end] - if {$escaped == 0} { - if {$c eq {"}} { - if {![info complete ${p}]} { - lappend waiting {"} - lappend innerpartials "" - } else { - if {[lindex $waiting end] eq {"}} { - #this quote is endquote - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - if {![info complete ${p}$c]} { - lappend waiting {"} - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } elseif {$c eq "\["} { - if {![info complete ${p}$c]} { - lappend waiting "\]" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } elseif {$c eq "\{"} { - if {![info complete ${p}$c]} { - lappend waiting "\}" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } else { - set p ${p}${c} - lset innerpartials end $p - } - set escaped 0 - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - set debug 0 - if {$debug} { - foreach w $waiting p $innerpartials { - puts stderr "->'$w' partial: $p" - } - } - return $incomplete - } - #This only works for very simple cases will get confused with for example: - # {set x "a["""} - proc incomplete_naive {partial} { - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - set waiting [list] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } - if {!$escaped} { - if {$c eq {"}} { - if {[lindex $waiting end] eq {"}} { - set waiting [lrange $waiting 0 end-1] - } else { - lappend waiting {"} - } - } elseif {$c eq "\["} { - lappend waiting "\]" - } elseif {$c eq "\{"} { - lappend waiting "\}" - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - } - } - } - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - return $incomplete - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::lib [namespace eval punk::lib { - variable pkg punk::lib - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.2.tm similarity index 99% rename from src/bootsupport/modules/punk/lib-0.1.1.tm rename to src/bootsupport/modules/punk/lib-0.1.2.tm index b6c6dd4a..5532ed33 100644 --- a/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/bootsupport/modules/punk/lib-0.1.2.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::lib 0.1.1 +# Application punk::lib 0.1.2 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.1.1] +#[manpage_begin punkshell_module_punk::lib 0 0.1.2] #[copyright "2024"] #[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk library}] [comment {-- Description at end of page heading --}] @@ -1105,7 +1105,7 @@ namespace eval punk::lib { } }] #puts stderr "$argspec" - set argd [punk::args::get_dict $argspec $args] + set argd [punk::args::parse $args withdef $argspec] set opts [dict get $argd opts] set dvar [dict get $argd values dictvar] @@ -1147,7 +1147,7 @@ namespace eval punk::lib { #package require punk ;#we need pipeline pattern matching features package require textblock - set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { @id -id ::punk::lib::showdict @cmd -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject @@ -1178,7 +1178,7 @@ namespace eval punk::lib { "dict or list value" patterns -default "*" -type string -multiple 1 -help\ "key or key glob pattern" - }] $args] + }]] #for punk::lib - we want to reduce pkg dependencies. # - so we won't even use the tcllib debug pkg here @@ -2870,7 +2870,7 @@ namespace eval punk::lib { proc list_as_lines {args} { #*** !doctools #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] - #[para]This simply joines the elements of the list with -joinchar + #[para]This simply joins the elements of the list with -joinchar #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. if {[set eop [lsearch $args --]] == [llength $args]-2} { @@ -2890,12 +2890,11 @@ namespace eval punk::lib { } proc list_as_lines2 {args} { #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? - lassign [tcl::dict::values [punk::args::get_dict { + lassign [tcl::dict::values [punk::args::parse $args withdef { -joinchar -default \n @values -min 1 -max 1 - } $args]] leaders opts values - puts "opts:$opts" - puts "values:$values" + }]] leaders opts values + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] } @@ -2932,10 +2931,10 @@ namespace eval punk::lib { #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc #we don't have to decide what is an opt vs a value #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) - lassign [tcl::dict::values [punk::args::get_dict { + lassign [tcl::dict::values [punk::args::parse $args withdef { @opts -any 1 -block -default {} - } $args]] leaderdict opts valuedict + }]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] } @@ -4198,10 +4197,10 @@ tcl::namespace::eval punk::lib::system { #get info about punk nestindex key ie type: list,dict,undetermined # pdict devel proc nestindex_info {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { -parent -default "" nestindex - } $args] + }] set opt_parent [dict get $argd opts -parent] if {$opt_parent eq ""} { set parent_type undetermined @@ -4229,7 +4228,7 @@ namespace eval ::punk::args::register { package provide punk::lib [tcl::namespace::eval punk::lib { variable pkg punk::lib variable version - set version 0.1.1 + set version 0.1.2 }] return diff --git a/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/bootsupport/modules/punk/libunknown-0.1.tm new file mode 100644 index 00000000..6f01e340 --- /dev/null +++ b/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -0,0 +1,1061 @@ +# -*- tcl -*- +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::libunknown 0.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::libunknown 0.1] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::libunknown] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::libunknown +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::libunknown +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + +tcl::namespace::eval punk::libunknown { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::libunknown}] + #[para] Core API functions for punk::libunknown + #[list_begin definitions] + + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + lappend PUNKARGS [list { + @id -id "(package)punk::libunknown" + @package -name "punk::libunknown" -help\ + "Experimental set of replacements for default 'package unknown' entries." + }] + + variable epoch + if {![info exists epoch]} { + set tmstate [dict create 0 {}] + set pkgstate [dict create 0 {}] + set tminfo [dict create current 0 epochs $tmstate] + set pkginfo [dict create current 0 epochs $pkgstate] + + set epoch [dict create tm $tminfo pkg $pkginfo] + } + + variable has_package_files + if {[catch {package files foobaz}]} { + set has_package_files 0 + } else { + set has_package_files 1 + } + + if {[info commands ::tcl::Pkg::source] ne ""} { + interp alias "" ::punk::libunknown::tcl_Pkg_source "" ::tcl::Pkg::source + } else { + #early 8.6 - pre tip459? + #we don't have + #::source -nopkg + proc tcl_Pkg_source {filename} { + uplevel 1 [list ::source $filename] + } + } + + #will use standard mechanism for non zipfs paths in the tm list. + proc zipfs_tm_UnknownHandler {original name args} { + # Import the list of paths to search for packages in module form. + # Import the pattern used to check package names in detail. + variable epoch + set pkg_epoch [dict get $epoch tm current] + + + #variable paths + upvar ::tcl::tm::paths paths + #variable pkgpattern + upvar ::tcl::tm::pkgpattern pkgpattern + + # Without paths to search we can do nothing. (Except falling back to the + # regular search). + set tid [format %-19s -] + catch {set tid [thread::id]} + + if {[llength $paths]} { + set pkgpath [string map {:: /} $name] + set pkgroot [file dirname $pkgpath] + if {$pkgroot eq "."} { + set pkgroot "" + } + + # We don't remember a copy of the paths while looping. Tcl Modules are + # unable to change the list while we are searching for them. This also + # simplifies the loop, as we cannot get additional directories while + # iterating over the list. A simple foreach is sufficient. + + if {[info commands ::tcl::zipfs::root] ne ""} { + set zipfsroot [tcl::zipfs::root] + set has_zipfs 1 + } else { + set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands + set has_zipfs 0 + } + + set satisfied 0 + foreach path $paths { + if {![interp issafe] && ![file exists $path]} { + continue + } + set currentsearchpath [file join $path $pkgroot] + + # Get the module files out of the subdirectories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. + + set use_epoch_for_all 1 + if {$use_epoch_for_all || [string match $zipfsroot* $path]} { + if {[dict exists $epoch tm epochs $pkg_epoch indexes $currentsearchpath]} { + #indexes are actual .tm files here + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" + } else { + + if {![interp issafe] && ![file exists $currentsearchpath]} { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + continue + } + + + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + + # ################################################################# + if {$has_zipfs && [string match $zipfsroot* $path]} { + set tmfiles [::tcl::zipfs::list $currentsearchpath/*.tm] ;#could theoretically be a dir - this is effectively a tree traversal + foreach tm_path $tmfiles { + dict set epoch tm epochs $pkg_epoch indexes [file dirname $tm_path] $tm_path $pkg_epoch + } + #retrieval using tcl::zipfs::list got (and cached) extras - limit to currentsearchpath + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + } else { + set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] + foreach tm_path $tmfiles { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $tm_path $pkg_epoch + } + } + #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles (UNcached): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" + + # ################################################################# + } + if {![llength $tmfiles]} { + continue + } + + # like normal processing - but track added (for static zipfs) + + set can_skip_update 0 + if {[string match $zipfsroot* $path]} { + #static tm location + if {[dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath]} { + if {![dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath $name]} { + #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. + #puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP orig:$original name:$name args:$args searchpath:$currentsearchpath" + set can_skip_update 1 + } else { + #if this name is in 'added' then we must have done something like a package forget or it wouldn't come back to package unknown + #dict unset epoch tm epochs $pkg_epoch added $currentsearchpath $name + } + } + } else { + #dynamic - can only skip if negatively cached for the current epoch + if {[dict exists $epoch tm epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_update 1 + } + + } + + if {!$can_skip_update} { + set strip [llength [file split $path]] + set found_name_in_currentsearchpath 0 ;#for negative cache by epoch + catch { + foreach file $tmfiles { + set pkgfilename [join [lrange [file split $file] $strip end] ::] + + if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { + # Ignore everything not matching our pattern for + # package names. + continue + } + try { + package vcompare $pkgversion 0 + } on error {} { + # Ignore everything where the version part is not + # acceptable to "package vcompare". + continue + } + + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. + continue + } + + # We have found a candidate, generate a "provide script" + # for it, and remember it. Note that we are using ::list + # to do this; locally [list] means something else without + # the namespace specifier. + + # NOTE. When making changes to the format of the provide + # command generated below CHECK that the 'LOCATE' + # procedure in core file 'platform/shell.tcl' still + # understands it, or, if not, update its implementation + # appropriately. + # + # Right now LOCATE's implementation assumes that the path + # of the package file is the last element in the list. + + package ifneeded $pkgname $pkgversion \ + "[::list package provide $pkgname $pkgversion];[::list source $file]" + + #JMN + #store only once for each name, although there may be multiple versions + dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkg_epoch + + # We abort in this unknown handler only if we got a + # satisfying candidate for the requested package. + # Otherwise we still have to fallback to the regular + # package search to complete the processing. + + if {($pkgname eq $name) + && [package vsatisfies $pkgversion {*}$args]} { + set satisfied 1 + + # We do not abort the loop, and keep adding provide + # scripts for every candidate in the directory, just + # remember to not fall back to the regular search + # anymore. + #(obsolete for libunknown - review) + } + + if {$pkgname eq $name} { + #can occur multiple times, different versions + #record package name as found in this path whether version satisfies or not + set found_name_in_currentsearchpath 1 + } + } + } + if {!$found_name_in_currentsearchpath} { + #can record as unfound for this path - for this epoch + dict set epoch tm epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + } + + } else { + #non zipfs tm path - normal processing + # We always look for _all_ possible modules in the current + # path, to get the max result out of the glob. + set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] + set strip [llength [file split $path]] + catch { + foreach file $tmfiles { + set pkgfilename [join [lrange [file split $file] $strip end] ::] + + if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { + # Ignore everything not matching our pattern for + # package names. + continue + } + try { + package vcompare $pkgversion 0 + } on error {} { + # Ignore everything where the version part is not + # acceptable to "package vcompare". + continue + } + + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. + continue + } + + # We have found a candidate, generate a "provide script" + # for it, and remember it. Note that we are using ::list + # to do this; locally [list] means something else without + # the namespace specifier. + + # NOTE. When making changes to the format of the provide + # command generated below CHECK that the 'LOCATE' + # procedure in core file 'platform/shell.tcl' still + # understands it, or, if not, update its implementation + # appropriately. + # + # Right now LOCATE's implementation assumes that the path + # of the package file is the last element in the list. + + package ifneeded $pkgname $pkgversion \ + "[::list package provide $pkgname $pkgversion];[::list source $file]" + + # We abort in this unknown handler only if we got a + # satisfying candidate for the requested package. + # Otherwise we still have to fallback to the regular + # package search to complete the processing. + + if {($pkgname eq $name) + && [package vsatisfies $pkgversion {*}$args]} { + set satisfied 1 + + # We do not abort the loop, and keep adding provide + # scripts for every candidate in the directory, just + # remember to not fall back to the regular search + # anymore. + } + } + } + + } + ##ZZZ + + } + + if {$satisfied} { + ##return + } + } + + # Fallback to previous command, if existing. See comment above about + # ::list... + + if {[llength $original]} { + #puts "zipfs_tm_UnknownHandler passing on to: $original [::linsert $args 0 $name]" + uplevel 1 $original [::linsert $args 0 $name] + } + } + proc zipfs_tclPkgUnknown {name args} { + #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" + + variable epoch + set pkg_epoch [dict get $epoch pkg current] + + + #global auto_path env + global auto_path + + if {![info exists auto_path]} { + return + } + + set tid [format %-19s -] + catch {set tid [thread::id]} + + if {[info commands ::tcl::zipfs::root] ne ""} { + set zipfsroot [tcl::zipfs::root] + set has_zipfs 1 + } else { + set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands + set has_zipfs 0 + } + + + #review - think about this + #typical dict size might be 800 packages - values are versions + #we probably don't need to create/destroy it for each iteration of the wile. + #question is whether some pkgIndex.tcl files may do a package forget? They probably don't/shouldn't(?) Does that matter here anyway? + set before_dict [dict create] + + + # Cache the auto_path, because it may change while we run through the + # first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + + # Make sure we only scan each directory one time. + if {[info exists tclSeenPath($dir)]} { + set use_path [lrange $use_path 0 end-1] + continue + } + set tclSeenPath($dir) 1 + + # Get the pkgIndex.tcl files in subdirectories of auto_path directories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. + + set use_epoch_for_all 1 + if {$use_epoch_for_all || [string match $zipfsroot* $dir]} { + set currentsearchpath $dir + if {[dict exists $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]} { + set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]] + #puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles ( cached ): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" + } else { + dict set epoch pkg epochs $pkg_epoch indexes $currentsearchpath [dict create] + # ################################################################# + set indexpaths [glob -directory $currentsearchpath -join -nocomplain * pkgIndex.tcl] + foreach idxpath $indexpaths { + dict set epoch pkg epochs $pkg_epoch indexes $currentsearchpath $idxpath 1 + } + set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]] + #puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles (UNcached): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" + # ################################################################# + } + if {![llength $indexfiles]} { + continue + } + + set can_skip_sourcing 0 + if {$has_zipfs && [string match $zipfsroot* $dir]} { + #static auto_path dirs + #can avoid scan if added via this path in any epoch + if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { + if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { + #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. + #puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath" + set can_skip_sourcing 1 + } else { + #if this name is in added then we must have done a package forget or it wouldn't come back to package unknown ? + #remove it and let it be readded if it's still provided by this path? + #probably doesn't make sense for static path? + #dict unset epoch pkg epochs $pkg_epoch added $currentsearchpath $name + } + } + } else { + #dynamic auto_path dirs - libs could have been added/removed + #scan unless cached negative for this epoch + if {[dict exists $epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_sourcing 1 + } + } + #An edge case exception is that after a package forget, a deliberate call to 'package require non-existant' + #will not trigger rescans for all versions of other packages. + #A rescan of a specific package for all versions can still be triggered with a package require for + #an exact non-existant version. e.g package require md5 0-0 + #(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range) + + set sourced 0 + if {!$can_skip_sourcing} { + #Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version. + #this will stop us rescanning everything properly by doing a 'package require nonexistant' + + #use 'info exists' to only call package names once and then append? worth it? + if {![info exists before_pkgs]} { + set before_pkgs [package names] + } + #update the before_dict which persists across while loop + foreach bp $before_pkgs { + dict set before_dict $bp [package versions $bp] + } + catch { + foreach file $indexfiles { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + #puts stderr "----->0 sourcing $file" + incr sourced ;#count as sourced even if source fails; keep before actual source action + #::tcl::Pkg::source $file + tcl_Pkg_source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + } + set dir [lindex $use_path end] + if {![info exists procdDirs($dir)]} { + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file exists", + if {([interp issafe] || [file exists $file])} { + try { + #puts "----->2 sourcing $file" + incr sourced + #::tcl::Pkg::source $file + tcl_Pkg_source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + #dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create] + + #avoid calculating package and version diffs if nothing was actually sourced + if {$sourced > 0} { + if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create] + #ensure there is an empty entry for the path if no packages added or changed versions + } + + set after_pkgs [package names] + set just_added [dict create] + if {[llength $after_pkgs] > [llength $before_pkgs]} { + foreach a $after_pkgs { + if {![dict exists $before_dict $a]} { + dict set just_added $a 1 + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $pkg_epoch + } + } + #puts stderr ">>>zipfs_tclPkgUnknown added [llength $added_pkgs]" + #puts stderr ">>> [join [lrange $added_pkgs 0 10] \n]..." + } + dict for {bp bpversions} $before_dict { + if {[dict exists $just_added $bp]} { + continue + } + if {[llength $bpversions] != [llength [package versions $bp]]} { + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $pkg_epoch + } + } + #puts stderr "zipfs_tclPkgUnknown $tid sourced: $sourced (under path: $currentsearchpath)" + if {$name ni $after_pkgs} { + #cache negative result (for this epoch only) + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } elseif {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + + lappend before_pkgs {*}[dict keys $just_added] + } + } + + } else { + #normal processing - not a static filesystem - we can't skip. + set indexfiles [glob -directory $dir -join -nocomplain * pkgIndex.tcl] + catch { + foreach file $indexfiles { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + #puts "----->1 sourcing $file" + ::tcl::Pkg::source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + } + + set dir [lindex $use_path end] + if {![info exists procdDirs($dir)]} { + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file exists", + if {([interp issafe] || [file exists $file])} { + try { + #puts "----->2 sourcing $file" + ::tcl::Pkg::source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + + } + + + set use_path [lrange $use_path 0 end-1] + + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. + set index 0 + if {[llength $old_path] == [llength $auto_path]} { + foreach dir $auto_path old $old_path { + if {$dir ne $old} { + # This entry in $::auto_path has changed. + break + } + incr index + } + } + + # $index now points to the first element of $auto_path that has + # changed, or the beginning if $auto_path has changed length Scan the + # new elements of $auto_path for directories to add to $use_path. + # Don't add directories we've already seen, or ones already on the + # $use_path. + foreach dir [lrange $auto_path $index end] { + if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { + lappend use_path $dir + } + } + set old_path $auto_path + } + #puts "zipfs_tclPkgUnknown DONE" + } + proc epoch_incr_pkg {args} { + if {[catch { + global auto_path + upvar ::punk::libunknown::epoch epoch + set prev_e [dict get $epoch pkg current] + set current_e [expr {$prev_e + 1}] + dict set epoch pkg current $current_e + dict set epoch pkg epochs $current_e [dict create] + if {[dict exists $epoch pkg epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + set zroot [zipfs root] + dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] { + if {[string match $zroot* $searchpath]} { + set stillvalid 0 + foreach a $auto_path { + if {[string match $a* $searchpath]} { + set stillvalid 1 + break + } + } + if {$stillvalid} { + dict set epoch pkg epochs $current_e indexes $searchpath $indexfiles + } + } + } + } + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e indexes]] + set index_count 0 + dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] { + #update prev epoch to be basic statistical info only + incr index_count [llength $indexfiles] + } + dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count] + dict unset epoch pkg epochs $prev_e indexes + } else { + dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0] + } + if {[dict exists $epoch pkg epochs $prev_e added]} { + #bring across - each lib will have previous epoch number + dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added] + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e added]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e added] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch pkg epochs $prev_e added + } else { + dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0] + } + if {[dict exists $epoch pkg epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch pkg epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch pkg epochs $prev_e unfound + } + } errM]} { + puts stderr "epoch_incr_pkg error\n $errM" + } + } + proc epoch_incr_tm {args} { + if {[catch { + upvar ::punk::libunknown::epoch epoch + set prev_e [dict get $epoch tm current] + set current_e [expr {$prev_e + 1}] + dict set epoch tm current $current_e + dict set epoch tm epochs $current_e [dict create] + set tmlist [tcl::tm::list] + if {[dict exists $epoch tm epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + set zroot [zipfs root] + dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] { + if {[string match $zroot* $searchpath]} { + #check all valid for current state of tcl::tm::list + set stillvalid 0 + foreach tm_path $tmlist { + if {[string match $tm_path* $searchpath]} { + set stillvalid 1 + break + } + } + if {$stillvalid} { + dict set epoch tm epochs $current_e indexes $searchpath $indexfiles + } + } + } + } + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e indexes]] + set index_count 0 + dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] { + #update prev epoch to be basic statistical info only + incr index_count [llength $indexfiles] + } + dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count] + dict unset epoch tm epochs $prev_e indexes + } else { + dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0] + } + if {[dict exists $epoch tm epochs $prev_e added]} { + #bring across - each lib will have previous epoch number + dict set epoch tm epochs $current_e added [dict get $epoch tm epochs $prev_e added] + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e added]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e added] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch tm epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch tm epochs $prev_e added + } else { + dict set epoch tm epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0] + } + if {[dict exists $epoch tm epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch tm epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch tm epochs $prev_e unfound + } + + } errM]} { + puts stderr "epoch_incr_tm error\n $errM" + } + } + + proc init {} { + if {[catch {tcl::tm::list} tmlist]} { + set tmlist [list] + } + set apath [list] + if {[info commands tcl::tm::list] ne ""} { + set tmlist [tcl::tm::list] + } + if {[info exists ::auto_path]} { + set apath $::auto_path + } + if {![llength $tmlist] && ![llength $apath]} { + #shouldn't happen - be noisy about it for now + puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path" + } + + if {[namespace origin ::package] eq "::punk::libunknown::package"} { + #This is far from conclusive - there may be other renamers (e.g commandstack) + return + } + if {[info commands ::punk::libunknown::package] ne ""} { + puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]" + return + } + + trace add variable ::auto_path write ::punk::libunknown::epoch_incr_pkg + trace add variable ::tcl::tm::paths write ::punk::libunknown::epoch_incr_tm + #set stackrecord [commandstack::rename_command -renamer punk::libunknown package {args} { + # #::package override installed by punk::libunknown::init + #} + proc package args { + switch -- [lindex $args 0] { + fo - for - forge - forget { + variable has_package_files + #experimental - silently disallow forgetting things that didn't involve sourcing files + #What about static libs that also sourced files? + #packages loaded by c extensions? + #forgetting Tcl or tcl seems to be a bad idea - package require doesn't work afterwards (independent of this pkg) + set forgets_requested [lrange $args 1 end] + set ok_forgets [list] + foreach p $forgets_requested { + #'package files' not avail in early 8.6 + #There can be other custom 'package ifneeded' scripts that don't use source - but still need to be forgotten. + #a basic/trivial case: 'package ifneeded aaa 0.1.1 {package provide aaa 0.1.1}' + #it could also use 'eval' instead of sourcing. + #For this reason - we shouldn't use 'package files' as any sort of indication of forgetability + #if {$p ni {tcl Tcl} && (!$has_package_files || [package provide $p] eq "" || ($has_package_files && [package provide $p] ne "" && [llength [package files $p]] > 0))} { + # lappend ok_forgets $p + #} + #What then? Hardcoded only for now? + if {$p ni {tcl Tcl tcl::oo}} { + #tcl::oo returns a comment only for its package provide script "# Already present, OK?" + # - so we can't use empty 'ifneeded' script as a determinant. + set vpresent [package provide $p] + if {$vpresent ne ""} { + #There could theoretically be other ifneeded scripts registered - but if the one in use is empty + #we'll use that as the criteria to disallow forget - REVIEW + set ifneededscript [package ifneeded $p $vpresent] + if {[string trim $ifneededscript] ne ""} { + lappend ok_forgets $p + } + } else { + #not loaded - but may have registered ifneeded script(s) in the package database + #assume ok to forget + lappend ok_forgets $p + } + } + } + if {[llength $ok_forgets]} { + return [::package:: forget {*}$ok_forgets] + } else { + return + } + } + ep - epo - epoc - epoch { + upvar ::punk::libunknown::epoch epoch + set epoch_args [lrange $args 1 end] + switch -- [llength $epoch_args] { + 0 { + set tm_epoch [dict get $epoch tm current] + set pkg_epoch [dict get $epoch pkg current] + return [dict create tm $tm_epoch pkg $pkg_epoch] + } + 1 { + switch -- [lindex $epoch_args 0] { + tm { + set cur [dict get $epoch tm current] + return [dict create $cur [dict get $epoch tm epochs $cur]] + } + pkg { + set cur [dict get $epoch pkg current] + return [dict create $cur [dict get $epoch pkg epochs $cur]] + } + incr { + epoch_incr_pkg + epoch_incr_tm + } + default { + error "package epoch [lindex $epoch_args 0] unsupported - known options: tm pkg incr" + } + } + } + 2 { + set a2 [list [lindex $epoch_args 0] [lindex $epoch_args 1]] + switch -- $a2 { + {pkg incr} - {incr pkg} { + epoch_incr_pkg + } + {tm incr} - {incr tm} { + epoch_incr_tm + } + default { + set which [lindex $epoch_args 0] + set index [lindex $epoch_args 1] + if {$which in {pkg tm}} { + set epochs [dict keys [dict get $epoch $which epochs]] + if {[catch { + set epochinfo [dict get $epoch $which epochs $index] + } errM]} { + error "package epoch $which unable to use index $index" + } + return $epochinfo + } else { + error "package epoch {*}$a2 unsupported - expected 'pkg incr' or 'tm incr' or 'pkg ' or 'tm '" + } + } + } + } + default { + set which [lindex $epoch_args 0] + set index [lindex $epoch_args 1] + set keys [lrange $epoch_args 2 end] + if {$which in {pkg tm}} { + set epochs [dict keys [dict get $epoch $which epochs]] + if {[catch { + set epochinfo [dict get $epoch $which epochs $index] + } errM]} { + error "package epoch $which unable to use index $index" + } + if {![dict exists $epochinfo {*}$keys]} { + set topkeys [dict keys $epochinfo] + error "package epoch $which $index $keys not found. Toplevel keys: $topkeys" + } + return [dict get $epochinfo {*}$keys] + } else { + error "package epoch unimplemented" + } + } + } + } + default { + return [::package:: {*}$args] + } + } + } + rename ::package ::package:: + #all lowercase procs already exported from ::punk::libunknown + namespace eval :: [list ::namespace import ::punk::libunknown::package] + + #if {[info commands ::tcl::zipfs::root] ne ""} { + # set has_zipfs_tm 0 + # foreach t $tmlist { + # if {[string match [::tcl::zipfs::root]* $t]} { + # set has_zipfs_tm 1 + # break ;#zipfs_tm_UnknownHandler can handle either - a single zipfs path is enough + # } + # } + # set has_zipfs_auto 0 + # foreach a $apath { + # if {[string match [::tcl::zipfs::root]* $a]} { + # set has_zipfs_auto 1 + # break + # } + # } + # if {$has_zipfs_tm || $has_zipfs_auto} { + # if {$has_zipfs_tm && $has_zipfs_auto} { + # package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + # } elseif {$has_zipfs_tm} { + # package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::tclPkgUnknown} + # } else { + # #must only have auto + # #puts "tmlist : $tmlist" + # #puts "autopath: $apath" + # package unknown {::tcl::tm::UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + # } + # } + # #review - tm and auto_path entries for safebase interps are obscured. For now we will ignore and defaults will apply. + # #to load in safebase anyway - module would probably have to be passed to interp as source to eval? + #} + + if {![interp issafe]} { + package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + } + + } + + proc default {} { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::libunknown ---}] +} +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::libunknown +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::libunknown [tcl::namespace::eval punk::libunknown { + variable pkg punk::libunknown + variable version + set version 0.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm index fa9e8d7c..7377929a 100644 --- a/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc { cd $original_wd } proc validate {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::mix::commandset::doc::validate - -- -type none -optional 1 -help "end of options marker --" + -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 - } $args] + }] set opt_individual [tcl::dict::get $argd opts -individual] set patterns [tcl::dict::get $argd values patterns] - + #todo - run and validate punk::docgen output set projectdir [punk::repo::find_project] if {$projectdir eq ""} { diff --git a/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm index 05e94a25..47e37909 100644 --- a/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout { return [join $layouts \n] } + punk::args::define { + @id -id ::punk::mix::commandset::layout::collection::_default + @cmd -name ::punk::mix::commandset::layout::collection::_default + -startdir -type string + -not -type string -multiple 1 + globsearches -default * -multiple 1 + } proc _default {args} { - punk::args::get_dict [subst { - @id -id ::punk::mix::commandset::layout::collection::_default - @cmd -name ::punk::mix::commandset::layout::collection::_default - -startdir -type string - -not -type string -multiple 1 - globsearches -default * -multiple 1 - }] $args + punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default + set tdict_low_to_high [as_dict {*}$args] #convert to screen order - with higher priority at the top diff --git a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 98f171c7..8ef36e27 100644 --- a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap { namespace eval lib { #*** !doctools #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] - #[para] Library API functions for punk::mix::commandset::scriptwrap + #[para] Library API functions for punk::mix::commandset::scriptwrap #[list_begin definitions] - + punk::args::define { + @id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders + #*** !doctools + #[call [fun get_wrapper_folders] [arg args] ] + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo + #[para] Arguments: + # [list_begin arguments] + # [arg_def string args] name-value pairs -scriptpath + # [list_end] + @cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\ + "Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo" + @opts -anyopts 0 + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + @values -minvalues 0 -maxvalues 0 + } proc get_wrapper_folders {args} { - set argd [punk::args::get_dict { - #*** !doctools - #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo - #[para] Arguments: - # [list_begin arguments] - # [arg_def string args] name-value pairs -scriptpath - # [list_end] - @id -id ::punk::mix::commandset::scriptwrap - @cmd -name punk::mix::commandset::get_wrapper_folders - - @opts -anyopts 0 - -scriptpath -default "" -type directory\ - -help "" - #todo -help folder within a punk.templates provided area??? - - @values -minvalues 0 -maxvalues 0 - } $args] + set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders] # -- --- --- --- --- --- --- --- --- set opt_scriptpath [dict get $argd opts -scriptpath] diff --git a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index bce44dee..f018486d 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs { # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied + punk::args::define { + @id -id ::punk::nav::fs::dirfiles_dict + @cmd -name punk::nav::fs::dirfiles_dict + @opts -any 0 + -searchbase -default "" + -tailglob -default "\uFFFF" + #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) + -with_sizes -default "\uFFFF" -type string + -with_times -default "\uFFFF" -type string + @values -min 0 -max -1 -type string + } proc dirfiles_dict {args} { - set argspecs { - @id -id ::punk::nav::fs::dirfiles_dict - @opts -any 0 - -searchbase -default "" - -tailglob -default "\uFFFF" - #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string - -with_times -default "\uFFFF" -type string - @values -min 0 -max -1 -type string - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict] lassign [dict values $argd] leaders opts vals set searchspecs [dict values $vals] diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index b89bc021..b8ad757f 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -21,7 +21,7 @@ package require punk::lib package require punk::args tcl::namespace::eval ::punk::ns::evaluator { - #eval-_NS_xxx_NS_etc procs + #eval-_NS_xxx_NS_etc procs } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -33,7 +33,7 @@ tcl::namespace::eval punk::ns { } variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns - namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp + namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype resolve_command synopsis namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc catch { @@ -43,7 +43,7 @@ tcl::namespace::eval punk::ns { #debug level punk.ns.compile 3 } - #leading colon makes it hard (impossible?) to call directly if not within the namespace + #leading colon makes it hard (impossible?) to call directly if not within the namespace proc ns/ {v {ns_or_glob ""} args} { variable ns_current ;#change active ns of repl by setting ns_current @@ -67,7 +67,7 @@ tcl::namespace::eval punk::ns { if {$ns_or_glob eq ""} { set is_absolute 1 set ns_queried $ns_current - set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] set has_globchars [regexp {[*?]} $ns_or_glob] @@ -78,10 +78,10 @@ tcl::namespace::eval punk::ns { } set ns_current $ns_or_glob set ns_queried $ns_current - tailcall ns/ $v "" + tailcall ns/ $v "" } else { set ns_queried $ns_or_glob - set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] } } else { if {!$has_globchars} { @@ -91,10 +91,10 @@ tcl::namespace::eval punk::ns { } set ns_current $nsnext set ns_queried $nsnext - set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] } else { set ns_queried [nsjoin $ns_current $ns_or_glob] - set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] } } } @@ -103,7 +103,7 @@ tcl::namespace::eval punk::ns { if {$ns_current in [info commands $ns_current] } { if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { if {[llength $ensemble_info] > 0} { - #this namespace happens to match ensemble command. + #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" } @@ -158,7 +158,7 @@ tcl::namespace::eval punk::ns { } else { set out [get_nslist -match [nsjoin $nsq *] -types [list all]] } - #set out [nslist [nsjoin $nsq *]] + #set out [nslist [nsjoin $nsq *]] set ns_current $nsq append out "\n$ns_current" return $out @@ -252,8 +252,15 @@ tcl::namespace::eval punk::ns { } else { set nsfq $ns } - set ns_script [nseval_ifexists_getscript $nsfq] - uplevel 1 [list {*}$ns_script $script] + if {[lsearch [nsparts $nsfq] :*] >=0} { + #weird_ns + set ns_script [nseval_ifexists_getscript $nsfq] + return [uplevel 1 [list {*}$ns_script $script]] + } else { + if {[namespace exists $nsfq]} { + return [namespace eval $nsfq $script] + } + } } proc nseval_ifexists_getscript {location} { set parts [nsparts $location] @@ -323,7 +330,7 @@ tcl::namespace::eval punk::ns { } #Note nsjoin,nsjoinall,nsprefix,nstail are string functions that don't care about namespaces in existence. - #Some functions in punk::ns are + #Some functions in punk::ns are proc nsjoin {prefix name} { if {[string match ::* $name]} { @@ -422,19 +429,19 @@ tcl::namespace::eval punk::ns { #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y - #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them + #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) - #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string + #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' - #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah - # is this :: punk :etc :blah or :: punk :etc: blah - #clearly leading/trailing colons in namespaces and commands are just a bad idea. + #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah + # is this :: punk :etc :blah or :: punk :etc: blah + #clearly leading/trailing colons in namespaces and commands are just a bad idea. #nsparts will prefer leading colon (ie greedy on ::) #This is important to support leading colon commands such as :/ # ie ::punk:::jjj:::etc -> :: punk :jjj :etc proc nsparts {nspath} { set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] if {[lindex $parts end] eq ""} { @@ -526,7 +533,7 @@ tcl::namespace::eval punk::ns { proc nstree {{location ""}} { if {![string match ::* $location]} { set nscaller [uplevel 1 {::namespace current}] - set location [nsjoin $nscaller $location] + set location [nsjoin $nscaller $location] } list_as_lines [nstree_list $location] } @@ -548,18 +555,18 @@ tcl::namespace::eval punk::ns { set subnslist [dict get $opts -subnslist] set allbelow [dict get $opts -allbelow] ;#whether to return matches longer than the matched glob-path # -- ---- --- --- --- --- - + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $location]] set has_globchars [regexp {[*?]} $ns_absolute] ;#don't use regexes on plain namespaces with no glob chars if {!$has_globchars && !$allbelow && ![llength $subnslist]} { - #short circuit trivial case + #short circuit trivial case return [list $location] } - - set base "" + + set base "" set tailparts [list] - if {$CALLDEPTH == 0} { + if {$CALLDEPTH == 0} { set parts [nsparts $ns_absolute] lset parts 0 :: set idx 0 @@ -577,12 +584,12 @@ tcl::namespace::eval punk::ns { set base $ns_absolute } } else { - set base $location + set base $location set tailparts $subnslist } if {![tcl::namespace::exists $base]} { return [list] - } + } #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] @@ -592,19 +599,19 @@ tcl::namespace::eval punk::ns { #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" - #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx + #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx if {[llength $tailparts]} { set nextglob [lindex $tailparts 0] if {$nextglob eq "**"} { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } elseif {[regexp {[*]{2}$} $nextglob]} { set nslist [list] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] foreach ch $nsmatches { lappend nslist $ch - #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] - lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] - } + #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] + } } else { #lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) set nslist [list] @@ -612,7 +619,7 @@ tcl::namespace::eval punk::ns { if {[llength $tailparts] >1 || $allbelow} { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { #if only one tailpart remaining and not $allbelow - then we already have what we need @@ -626,13 +633,13 @@ tcl::namespace::eval punk::ns { set nslist [list] foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] } } else { set nslist $allchildren } #set nsmatches $allchildren - #set nslist [nstree_list $base -subnslist {} -allbelow 0] + #set nslist [nstree_list $base -subnslist {} -allbelow 0] } set nslist [lsort -unique $nslist] @@ -652,10 +659,10 @@ tcl::namespace::eval punk::ns { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } } @@ -670,14 +677,14 @@ tcl::namespace::eval punk::ns { if {$base ni $nslist} { #puts stderr "> adding $base to $nslist" set nslist [list $base {*}$nslist] - } + } if {$has_globchars} { if {$allbelow} { foreach ns $nslist { if {[globmatchns ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { set nslist_filtered [struct::list::Lfilter $nslist [list globmatchns ${ns_absolute}]] } @@ -687,7 +694,7 @@ tcl::namespace::eval punk::ns { if {[string equal ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { #set nslist_filtered [struct::list::Lfilter $nslist [list string match ${ns_absolute}]] set nslist_filtered [list $ns_absolute] @@ -705,9 +712,54 @@ tcl::namespace::eval punk::ns { if {$ansicodes eq ""} { return $usageinfo_char } elseif {$ansicodes eq "\UFFEF"} { - return " [a+ brightyellow]$usageinfo_char[a]" + return "[a+ brightyellow]$usageinfo_char[a]" + } else { + return "[a+ {*}$ansicodes]$usageinfo_char[a]" + } + } + + punk::args::define { + @id -id ::punk::ns::Cmark + @cmd -name punk::ns::Cmark + @leaders + type -choices {oo ooc ooo punkargs ensemble native} -choicelabels { + oo " symbol \u25c6" + ooc " symbol \u25c7" + ooo " symbol \u25c8" + punkargs " symbol \U1f6c8" + ensemble " symbol \u24ba" + native " symbol \u24c3" + unknown " symbol \u2370" + } + @opts + @values -min 0 -max -1 + ansiname -type string -optional 1 -multiple 1 -help\ + "ansi names as accepted by punk::ansi::a+ + e.g + red bold + (Not raw ansi codes)" + } + proc Cmark {args} { + if {[llength $args] == 0} { + punk::args::parse {} withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + set type [lindex $args 0] + set type [tcl::prefix::match -error "" {oo ooc ooo punkargs ensemble native unknown} $type] + set ansinames [lrange $args 1 end] + switch -- $type { + oo - ooc - ooo - punkargs - ensemble - native - unknown {} + default { + #punk::args::usage ::punk::ns::Cmark + punk::args::parse $args withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + } + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + if {[llength $ansinames]} { + return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]" } else { - return " [a+ {*}$ansicodes]$usageinfo_char[a]" + return [dict get $marks $type] } } @@ -720,7 +772,7 @@ tcl::namespace::eval punk::ns { -nsdict ""\ ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- set fq_glob [dict get $opts -match] set requested_types [dict get $opts -types] set opt_nsdict [dict get $opts -nsdict] @@ -749,7 +801,7 @@ tcl::namespace::eval punk::ns { } foreach t $types { switch -- $t { - oo - all - + oo - all - children - commands - exported - imported - aliases - procs - ensembles - ooclasses - ooobjects - ooprivateobjects - ooprivateclasses - native - coroutines - interps - zlibstreams {} default { error "Unrecognised namespace member type: $t known types: $known_types oo all" @@ -783,19 +835,19 @@ tcl::namespace::eval punk::ns { set usageinfo [list] if {$opt_nsdict eq ""} { - set nsmatches [get_ns_dicts $fq_glob -allbelow 0] + set nsmatches [get_ns_dicts $fq_glob -allbelow 0] set itemcount 0 set matches_with_results [list] foreach nsinfo $nsmatches { - set itemcount [dict get $nsinfo itemcount] + set itemcount [dict get $nsinfo itemcount] if {$itemcount > 0} { lappend matches_with_results $nsinfo - } + } } if {[llength $matches_with_results] == 1} { set contents [lindex $matches_with_results 0] } elseif {[llength $matches_with_results] > 1} { - puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" + puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" set contents [lindex $matches_with_results 0] } else { return "- no results -" @@ -806,7 +858,7 @@ tcl::namespace::eval punk::ns { return "- no results -" } } - set ns [dict get $contents location] + set ns [dict get $contents location] package require overtype if {"children" in $types} { @@ -871,19 +923,19 @@ tcl::namespace::eval punk::ns { } #elements are commands and possibly renamed aliases which may or may not have been renamed into the current namespace - #a command could be an empty string or something else weird. + #a command could be an empty string or something else weird. #Primarily just to handle empty string command - we will wrap each command as a 2-part element here #(our foreach loop needs to ignore missing commands - but not empty string) set elements [lmap v $commands {list c $v}] set seencmds [list] - set masked [list] ;# + set masked [list] ;# #jmn #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { - #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo + #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo #we can detect masking by proc/ensemble/oo - but not by a binary extension loaded after the rename: REVIEW if {$a in $cmdsets} { #we have an alias that is also a known other command-type @@ -896,15 +948,15 @@ tcl::namespace::eval punk::ns { } } set elements [lsort -index 1 $elements] - - + + set numelements [llength $elements] if {$numelements} { set split1 [expr {int(ceil($numelements/4.0))}] set elements1 [lrange $elements 0 $split1-1] set remaining3 [lrange $elements $split1 end] - set numremaining3 [llength $remaining3] + set numremaining3 [llength $remaining3] set split2 [expr {int(ceil($numremaining3/3.0))}] set elements2 [lrange $remaining3 0 $split2-1] set remaining2 [lrange $remaining3 $split2 end] @@ -1019,12 +1071,12 @@ tcl::namespace::eval punk::ns { } } if {$cmd in $usageinfo} { - set u [Usageinfo_mark brightgreen] + set u " [Cmark punkargs brightgreen]" } else { set u "" } set cmd$i "${prefix} $c$cmd_display$u" - #set c$i $c + #set c$i $c set c$i "" lappend seencmds $cmd } @@ -1033,7 +1085,7 @@ tcl::namespace::eval punk::ns { #lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] lappend displaylist $a1[overtype::left $col1 $ch1][a]$a1[overtype::left $col2 $ch2][a]$c1[overtype::left $col3 $cmd1][a]$c2[overtype::left $col4 $cmd2][a]$c3[overtype::left $col5 $cmd3][a]$c4$cmd4[a] } - + return [list_as_lines $displaylist] } proc nspath_here_absolute {{nspath "\uFFFF"}} { @@ -1060,12 +1112,13 @@ tcl::namespace::eval punk::ns { return [nsjoin $base $nspath] } + variable has_textblock set has_textblock [expr {![catch {package require textblock}]}] if {$has_textblock} { interp alias "" ::punk::ns::Block_width "" textblock::width - } else { - #maint - equiv of textblock::width + } else { + #maint - equiv of textblock::width proc Block_width {textblock} { if {$textblock eq ""} { return 0 } if {[tcl::string::last \t $textblock] >=0} { @@ -1085,38 +1138,55 @@ tcl::namespace::eval punk::ns { return [punk::char::ansifreestring_width $textblock] } } - proc nslist {{glob "*"} args} { - set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] - if {[dict exists $args -match]} { - #review - presumably this is due to get_nslist taking -match? - error "nslist requires positional argument 'glob' instead of -match option" - } - set defaults [dict create\ - -match $ns_absolute\ - -nspathcommands 0\ - ] - set opts [dict merge $defaults $args] + punk::args::define { + @id -id ::punk::ns::nslist + @cmd -name punk::ns::nslist -help\ + "Return a textual representation of + the child namespaces and commands within + the namespace(s) matched by glob." + @opts + -nspathcommands -type boolean -default 0 + -types + @values -min 0 -max -1 + glob -multiple 1 -optional 1 -default "*" + } + proc nslist {args} { + set argd [punk::args::parse $args withid ::punk::ns::nslist] + lassign [dict values $argd] leaders opts values received solos multis + + #if {[dict exists $args -match]} { + # #review - presumably this is due to get_nslist taking -match? + # error "nslist requires positional argument 'glob' instead of -match option" + #} + #set defaults [dict create\ + # -match $ns_absolute\ + # -nspathcommands 0\ + #] + #set opts [dict merge $defaults $args] # -- --- --- set opt_nspathcommands [dict get $opts -nspathcommands] # -- --- --- - - - set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + set globlist [dict get $values glob] set with_results [list] - foreach nsdict $ns_matches { - if {[dict get $nsdict itemcount]>0} { - lappend with_results $nsdict + foreach glob $globlist { + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] + set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + foreach nsdict $ns_matches { + if {[dict get $nsdict itemcount]>0} { + lappend with_results $nsdict + } } } - #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' + #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' set count_with_results [llength $with_results] set output "" + variable has_textblock foreach nsdict $with_results { - dict set opts -nsdict $nsdict - set block [get_nslist {*}$opts] + set loc [dict get $nsdict location] + set block [get_nslist -nsdict $nsdict -match ${loc}::* {*}$opts] #if {[string first \n $block] < 0} { # #single line # set width [Block_width [list $block]] @@ -1125,7 +1195,7 @@ tcl::namespace::eval punk::ns { #} set width [Block_width $block] - #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location + #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location if {$count_with_results > 1 || [regexp {[*?]} [nsprefix $ns_absolute]]} { append output \n [dict get $nsdict location] } @@ -1139,17 +1209,24 @@ tcl::namespace::eval punk::ns { } else { append path_text \n " also resolving cmds in namespace paths:" set nspathdict [dict get $nsdict namespacepath] - dict for {k v} $nspathdict { - set cmds [dict get $v commands] - append path_text \n " path: $k" - append path_text \n " cmds: $cmds" + if {!$has_textblock} { + dict for {k v} $nspathdict { + set cmds [dict get $v commands] + append path_text \n " path: $k" + append path_text \n " cmds: $cmds" + } + } else { + dict for {k v} $nspathdict { + set t [textblock::list_as_table -title $k -columns 6 [lsort [dict get $v commands]]] + append path_text \n $t + } } } append output $path_text set path_text_width [Block_width $path_text] - append output \n [string repeat - [expr {max($width,$path_text_width)}]] + append output \n [string repeat - [expr {max($width,$path_text_width)}]] } elseif {$count_with_results > 1 && $width > 0 } { - append output \n [string repeat - $width] + append output \n [string repeat - $width] } } return $output @@ -1160,7 +1237,7 @@ tcl::namespace::eval punk::ns { return [get_ns_dicts $ns_absolute {*}$args] } - #info cmdtype available in 8.7+ + #info cmdtype available in 8.7+ #safe interps also seem to have it disabled for some reason #we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc #IMPORTANT: don't detect easy types such as proc/import here - caller needs the 'na' to do the proper fallback @@ -1227,7 +1304,7 @@ tcl::namespace::eval punk::ns { } #we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller #also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! - return na + return na } #non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob #returns a list of dicts even if only one ns matched @@ -1260,17 +1337,18 @@ tcl::namespace::eval punk::ns { set glob [nstail $fq_glob] set matched_namespaces [nstree_list $nsglob -allbelow $allbelow] - set report_namespaces [list] + set report_namespaces [list] #special case trailing ** in last segment if {[regexp {[*]{2}$} $glob]} { - lappend report_namespaces {*}$matched_namespaces + lappend report_namespaces {*}$matched_namespaces foreach ns $matched_namespaces { lappend report_namespaces {*}[nstree_list [nsjoin $ns $glob]] } } else { - set report_namespaces $matched_namespaces + set report_namespaces $matched_namespaces } - punk::args::update_definitions $report_namespaces + #puts stderr "---->get_ns_dicts '$fq_glob $args' update_definitions $report_namespaces" + punk::args::update_definitions $report_namespaces set nsdict_list [list] foreach ch $report_namespaces { @@ -1280,27 +1358,27 @@ tcl::namespace::eval punk::ns { } else { set allchildren [nschildren $ch] ; #sorted, only returns 1 level deeper } - + #nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string. # By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {} #set commands [.= nscommands -raw [nsjoin $ch $glob] |> punk::lib::linelist -block {}] set commands [punk::lib::linelist -block {} [nscommands -raw [nsjoin $ch $glob]]] - #by convention - returning just \n represents a single result of the empty string whereas no results + #by convention - returning just \n represents a single result of the empty string whereas no results #after passing through linelist this becomes {} {} which appears as a list of two empty strings. - #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines + #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines #unless we always return a newline at the tail if there is a result #For this reason nscommands returns a trailing newline - so the last entry should always be empty string - and is a bogus entry - #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. + #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. if {[lindex $commands end] eq ""} { set commands [lrange $commands 0 end-1] } else { puts stderr "get_ns_dicts WARNING nscommands didn't return a trailing newline - unexpected" } - - + + #JMN - set location $ch + set location $ch set locationparts [nsparts $location] set weird_ns 0 if {[lsearch $locationparts :*] >= 0} { @@ -1309,7 +1387,7 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set exportpatterns [nseval_ifexists $location {::namespace export}] set nspathlist [nseval_ifexists $location {::namespace path}] - } else { + } else { set exportpatterns [tcl::namespace::eval $location {::namespace export}] set nspathlist [tcl::namespace::eval $location {::namespace path}] } @@ -1335,7 +1413,7 @@ tcl::namespace::eval punk::ns { #! info commands can't glob with a weird ns prefix #! info commands with no arguments returns all commands (from global and any other ns in namespace path) #lappend matched {*}[nseval_ifexists $location [list ::info commands [nsjoin ${location} $p]]] - lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { + lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { set allcommands [info commands] set matches [list] foreach c $allcommands { @@ -1360,9 +1438,9 @@ tcl::namespace::eval punk::ns { set allexported [lsort -unique $allexported] #NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace) if {$weird_ns} { - set allprocs [nseval_ifexists $location {::info procs}] + set allprocs [nseval_ifexists $location {::info procs}] } else { - set allprocs [tcl::namespace::eval $location {::info procs}] + set allprocs [tcl::namespace::eval $location {::info procs}] } #set allprocs [nseval $location {::info procs}] set childtails [lmap v $allchildren {nstail $v}] @@ -1382,24 +1460,24 @@ tcl::namespace::eval punk::ns { #use aliases glob - because aliases can be present with or without leading :: #NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases if {$weird_ns} { - set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } else { - set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } - #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] foreach a $raw_aliases { if {[string match *:: $a]} { #exception for alias such as ::p::2:: so that it doesn't show up as empty string #lappend aliases :: #JMN - 2023 - better to display an empty string somehow - lappend aliases "" + lappend aliases "" } else { lappend aliases [nstail $a] } } - #NOTE for 'info ...' 'namespace origin|(etc)..' + #NOTE for 'info ...' 'namespace origin|(etc)..' # - use the pattern [namespace eval $location [list $cmd]] #This allows examination of cmds with "bad" names such as empty string or prefixed with single colon. #while these should be rare - we want to handle such edge cases when browsing namespaces. @@ -1433,7 +1511,7 @@ tcl::namespace::eval punk::ns { } if {$weird_origin} { if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { @@ -1444,7 +1522,7 @@ tcl::namespace::eval punk::ns { } } else { if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { @@ -1454,7 +1532,7 @@ tcl::namespace::eval punk::ns { } } - } + } default { if {$ctype eq "import"} { if {$weird_ns} { @@ -1462,7 +1540,7 @@ tcl::namespace::eval punk::ns { } else { set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] } - #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source + #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source #ie we don't need to follow a chain of 'imported' results. set origin_location [nsprefix $cmdorigin] set origin_cmd [nstail $cmdorigin] @@ -1491,7 +1569,7 @@ tcl::namespace::eval punk::ns { lappend allensembles $cmd } i-alias - alias { - #review + #review lappend allaliases $cmd } i-object - object { @@ -1520,7 +1598,7 @@ tcl::namespace::eval punk::ns { lappend allzlibstreams $cmd } default { - #there may be other registered types + #there may be other registered types #(extensible with Tcl_RegisterCommandTypeName) lappend allothers $cmd } @@ -1535,7 +1613,7 @@ tcl::namespace::eval punk::ns { #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. set nsorigin [namespace origin ${location}::] } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] + set nsorigin [nseval $location "::namespace origin $cmd"] } else { set nsorigin [namespace origin [nsjoin $location $cmd]] } @@ -1585,12 +1663,12 @@ tcl::namespace::eval punk::ns { set imported $allimported set undetermined $allundetermined } - - #itemcount will overcount if we are including commands as well as procs/exported etc - + + #itemcount will overcount if we are including commands as well as procs/exported etc - set itemcount 0 incr itemcount [llength $childtailmatches] incr itemcount [llength $commands] - + #incr itemcount [llength $procs] #incr itemcount [llength $exported] @@ -1606,6 +1684,7 @@ tcl::namespace::eval punk::ns { set has_punkargs [expr {[info commands ::punk::args::id_exists] ne ""}] set has_tepam [expr {[info exists ::tepam::ProcedureList]}] if {$has_punkargs || $has_tepam} { + set ns_updated [dict create] foreach c $commands { if {$c in $imported} { set fq [namespace origin [nsjoin $location $c]] @@ -1613,7 +1692,7 @@ tcl::namespace::eval punk::ns { #TODO - use which_alias ? set tgt [interp alias "" [nsjoin $location $c]] if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] + set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] } set word1 [lindex $tgt 0] if {$word1 eq "punk::mix::base::_cli"} { @@ -1623,7 +1702,11 @@ tcl::namespace::eval punk::ns { } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) - set fq $word1 + if {[string match ::* $word1]} { + set fq $word1 + } else { + set fq ::$word1 + } } } else { set fq [nsjoin $location $c] @@ -1631,7 +1714,12 @@ tcl::namespace::eval punk::ns { if {$has_punkargs} { #set id [string trimleft $fq :] set id $fq - punk::args::update_definitions [list [namespace qualifiers $id]] + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1675,10 +1763,10 @@ tcl::namespace::eval punk::ns { ] lappend nsdict_list $nsdict } - return $nsdict_list + return $nsdict_list } #Must be no ansi when only single arg used. - #review - ansi codes will be very confusing in some scenarios! + #review - ansi codes will be very confusing in some scenarios! #todo - only output color when requested (how?) or via repltelemetry ? interp alias {} nscommands2 {} .= ,'ok'@0.= { #Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x @@ -1688,13 +1776,13 @@ tcl::namespace::eval punk::ns { ::set commandns [::namespace current] ::set commandlist [::list] #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway - #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed + #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed ::set colors [::list none cyan yellow green] ::set ci 0 ;#colourindex ::set do_raw 0 ::if {[::set posn [::lsearch $searchlist -raw]] >= 0} { ::set searchlist [::lreplace $searchlist $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } ::if {![::llength $searchlist]} { ::lappend searchlist * @@ -1714,7 +1802,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1731,7 +1819,7 @@ tcl::namespace::eval punk::ns { ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } if 0 { @@ -1771,19 +1859,19 @@ tcl::namespace::eval punk::ns { ::list ok [::list result $commandlist] #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. - } |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} = 0} { ::set args [::lreplace $args $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } if {![llength $args]} { lappend args * @@ -1801,7 +1889,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1817,7 +1905,7 @@ tcl::namespace::eval punk::ns { set weird_ns 0 if {[string match *:::* $base]} { set weird_ns 1 - } + } #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created if {$weird_ns} { ::if {![nsexists $base]} { @@ -1838,7 +1926,7 @@ tcl::namespace::eval punk::ns { }} $base $what ]] } else { ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] } @@ -1903,7 +1991,7 @@ tcl::namespace::eval punk::ns { info commands ${input} } } - } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + } errM]} { + puts stderr "$errM" + set origin $querycommand + set resolved $querycommand + } + } else { + #fully qualified command specified but doesn't exist + set origin $querycommand + set resolved $querycommand + } + } else { + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand + } else { + #set thispath [uplevel 1 [list ::nsthis $querycommand]] + set thispath [uplevel 1 [list ::punk::ns::nspath_here_absolute $querycommand]] + set targetns [nsprefix $thispath] + set name [nstail $thispath] + set targetparts [nsparts $targetns] + if {[lsearch $targetparts :*] >=0} { + #weird ns + set valid_ns [nsexists $targetns] + } else { + set valid_ns [namespace exists $targetns] + } + if {$valid_ns} { + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + }]} { + set thiscmd [nsjoin $targetns $name] + #relative querycommand specified - but Tcl didn't find a match in namespace path + #assume global (todo - look for namespace match in auto_index first ?) + set origin ::$name + set resolved ::$name + } + } else { + #namespace as relative to current doesn't seem to exist + #Tcl would also attempt to resolve as global + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::resolve_command $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand + + } + } + } + #ns::cmdtype only detects alias type on 8.7+? + set initial_cmdtype [punk::ns::cmdtype $origin] + switch -- $initial_cmdtype { + na - alias { + #REVIEW - alias entry doesn't necessarily match command! + #consider using which_alias (wiki) + set tgt [interp alias "" $origin] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft $origin :]] + } + #first word of tgt may be namespace relative or absolute + if {$tgt ne ""} { + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set targetword [lindex $tgt end] + } else { + #todo - alias may have prefilled some leading args - so usage report should reflect that??? + #(possible curried arguments) + #review - curried arguments could be for ensembles! + set targetword $word1 + return [namespace eval :: [list punk::ns::resolve_command $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + } + + + set origin $targetword + #retest cmdtype on modified origin + set cmdtype [punk::ns::cmdtype $origin] + } else { + set cmdtype $initial_cmdtype + } + if {$cmdtype eq "na"} { + #tcl 8.6 + if {[info object isa object $origin]} { + set cmdtype "object" + } + } + } + default { + set cmdtype $initial_cmdtype + } + } + + punk::args::update_definitions [list [namespace qualifiers $origin]] + set id $origin + + + #don't shortcircuit if no args id - need to allow (autodef) even for argumentless query e.g resolve_command dict + if {[punk::args::id_exists $id] && ![llength $queryargs]} { + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + #puts "--->resolve_command '$args' update_definitions [list [namespace qualifiers $origin]]" + if {![punk::args::id_exists $origin]} { + if {[namespace ensemble exists $origin]} { + #review + #todo - check -unknown + #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + #presumably -choiceprefix should be zero in that case?? + + set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] + + #review - we can have a combination of commands from -map as well as those exported from -namespace + # if and only if -subcommands is specified + + set subcommand_dict [dict create] + set commands [list] + set nscommands [list] + if {[llength [dict get $ensembleinfo -subcommands]]} { + #set exportspecs [namespace eval $ns {namespace export}] + #foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + #} + #when using -subcommands, even unexported commands are available + set nscommands [info commands ${ns}::*] + foreach sub [dict get $ensembleinfo -subcommands] { + if {[dict exists $map $sub]} { + #-map takes precence over same name exported from -namespace + dict set subcommand_dict $sub [dict get $map $sub] + } elseif {"${ns}::$sub" in $nscommands} { + dict set subcommand_dict $sub ${ns}::$sub + } else { + #subcommand probably supplied via -unknown handler? + dict set subcommand_dict $sub "" + } + } + } else { + if {[dict size $map]} { + set subcommand_dict $map + } else { + set exportspecs [namespace eval $ns {namespace export}] + foreach pat $exportspecs { + lappend nscommands {*}[info commands ${ns}::$pat] + } + foreach fqc $nscommands { + dict set subcommand_dict [namespace tail $fqc] $fqc + } + } + } + + + set subcommands [lsort [dict keys $subcommand_dict]] + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs + } + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + #must be exact match - not a prefix + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set resolve_next [list {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + puts "+++> resolve_next: $resolve_next" + + set sub_resolution [resolve_command {*}$resolve_next] + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + + #set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match] + + puts stderr "+++> $sub_resolution" + puts stderr "+++> $f" + dict set sub_resolution args_full $f + return $sub_resolution + } + } + + set choiceinfodict [dict create] + set choicelabeldict [dict create] + + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + dict set choiceinfodict $sub [list [list resolved $subwhat]] + + if {$targettail in [dict get $nsinfo usageinfo]} { + dict lappend choiceinfodict $sub {doctype punkargs} + #dict set choicelabeldict $sub [punk::ns::synopsis $subwhat] + } + if {$targettail in [dict get $nsinfo ensembles]} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + if {$targettail in [dict get $nsinfo ooobjects]} { + if {$targettail in [dict get $nsinfo ooclasses]} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$targettail in [dict get $nsinfo native]} { + dict lappend choiceinfodict $sub {doctype native} + } + } + + + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + set argdef [punk::lib::tstr -return string { + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + Ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -ensembleparameter 1 -help {leading ensemble parameter - passed to subcommand}" + } + } + append argdef \n $vline + punk::args::define $argdef + set id $autoid + } + } + #testing where id = $origin or id = (autodef)::$origin + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set specid $id + set specargs $queryargs + if {[llength $queryargs]} { + #JJJ + set spec [punk::args::get_spec $id] + #TODO -form + set form_names [dict get $spec form_names] + + #'subcommands' only allowed in single-form commands - review + set fid [lindex $form_names 0] + + set leadernames [dict get $spec FORMS $fid LEADER_NAMES] + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + #'subcommands' are only present in forms that consist solely of leaders - REVIEW + #(does not have to dispatch on 1st leader - e.g consider ensemble -parameters) + if {[llength $form_names] == 1 && ![llength $optnames] && ![llength $valnames]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + + set leadernames_matched [lrange $leadernames 0 [llength $queryargs]-1] + foreach q $queryargs lname $leadernames_matched { + if {$lname eq ""} { + break + } + set arginfo [dict get $spec FORMS $fid ARG_INFO $lname] + + set allchoices [list] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + set choiceinfo [punk::args::system::Dict_getdef $arginfo -choiceinfo {}] + set is_ensembleparam [punk::args::system::Dict_getdef $arginfo -ensembleparameter 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 {*}$clist + } + if {$is_ensembleparam} { + #review + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + if {![llength $allchoices]} { + #review - only leaders with a defined set of choices are eligible for consideration as a subcommand + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + + + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + break + } + if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { + #a unique prefix is not sufficient for this arg + break + } + + lappend nextqueryargs $resolved_q + lpop queryargs_untested 0 + if {$resolved_q ne $q} { + #we have our first difference - recurse with new query args + set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested] + set sub_resolution [punk::ns::resolve_command {*}$resolvelist] + #return $sub_resolution + + set sub_origin [dict get $sub_resolution origin] + set sub_argsremaining [dict get $sub_resolution args_remaining] + set sub_resolved [dict get $sub_resolution resolved] + set sub_cmdtype [dict get $sub_resolution cmdtype] + set sub_args_full [dict get $sub_resolution args_full] + puts stderr "===> $sub_resolution" + + return [dict create origin $sub_origin args_remaining $sub_argsremaining resolved $sub_resolved cmdtype $sub_cmdtype args_full $resolvelist] + + } + #check if subcommands so far have a custom args def + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set spec [punk::args::get_spec $currentid] + set form_names [dict get $spec form_names] + set fid [lindex $form_names 0] + + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] + + if {[llength $form_names] != 1} { + break + } + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + if {[llength $optnames] || [llength $valnames]} { + break + } + } else { + set is_subcommand_resolved 0 + set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] + set mapped_subcmd "" + foreach inf $cinfo { + if {[lindex $inf 0] eq "resolved"} { + set mapped_subcmd [lindex $inf 1] + set resolve_next [list {*}$mapped_subcmd {*}$queryargs_untested] + puts "---> resolve_next: $resolve_next" + set sub_resolution [punk::ns::resolve_command {*}$resolve_next] + + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + #set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs] + + puts stderr "---> $sub_resolution" + puts stderr "---> $f" + dict set sub_resolution args_full $f + return $sub_resolution + + + #puts stderr "---> $sub_resolution" + #return $sub_resolution + } + } + + #We can get no further with custom defs + #It is possible we have a documented lower level subcommand but missing the intermediate + #e.g if ::trace remove command was specified and is documented - it will be found above + #but if ::trace remove is not documented and the query is "::trace remove com" + #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + #that's probably ok. + break + } + } + } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs + } + } + + if {[string match (autodef)* $origin]} { + set origin [string range $origin 9 end] + } + + + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + punk::args::define { + @id -id ::punk::ns::forms + @cmd -name punk::ns::forms -help\ + "Return names for each form of a command" + @opts + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc forms {args} { + set argd [::punk::args::parse $args withid ::punk::ns::forms] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::forms $id + } + punk::args::define { + @id -id ::punk::ns::synopsis + @cmd -name punk::ns::synopsis -help\ + "Return synopsis for each form of a command + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc synopsis {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set opt_return [dict get $argd opts -return] + set cmdmembers [dict get $argd values cmditem] + + + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set resolved_id [dict get $cmdinfo origin] + set unresolved_args [dict get $cmdinfo args_remaining] + set full_args [dict get $cmdinfo args_full] + + #puts "---punk::args::synopsis resolve_command result: $cmdinfo" + #REVIEW + set n [llength $unresolved_args] + set idparts [lrange $full_args 0 end-$n] + + set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + if {$syn eq ""} { + return + } + + #when we use list operations on $syn - it can get extra braces due to ANSI - use join to bring back to a string without extraneous bracing + switch -- $opt_return { + full - summary { + set resultstr "" + foreach synline [split $syn \n] { + #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n + append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + } + set resultstr [string trimright $resultstr \n] + #set resultstr [join [lreplace $syn 0 0 {*}$idparts] " "] + return $resultstr + } + dict { + return $syn + } + } + } + proc synopsis_raw {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::synopsis -form $form $id + } + #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? # - as this is interactive generally introspection should be ok at the top level # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? @@ -1989,15 +2596,15 @@ tcl::namespace::eval punk::ns { It supports the following: 1) Procedures or builtins for which a punk::args definition has been loaded. - 2) tepam procedures (returns string form only) + 2) tepam procedures (returns string form only) 3) ensemble commands - auto-generated unless documented via punk::args (subcommands will show with an indicator if they are explicitly documented or are themselves ensembles) - 4) tcl::oo objects - auto-gnerated unless documented via punk::args + 4) tcl::oo objects - auto-gnerated unless documented via punk::args 5) dereferencing of aliases to find underlying command (will not work with some renamed aliases) - Note that native commands commands not explicitly documented will + Note that native commands commands not explicitly documented will generally produce no useful info. For example sqlite3 dbcmd objects could theoretically be documented - but as 'info cmdtype' just shows 'native' they can't (?) be identified as belonging to sqlite3 without @@ -2009,7 +2616,8 @@ tcl::namespace::eval punk::ns { } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - + -form -default 0 -help\ + "Ordinal index or name of command form" -- -type none -help\ "End of options marker Use this if the command to view begins with a -" @@ -2026,19 +2634,21 @@ tcl::namespace::eval punk::ns { #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { - dict set opts -scheme info + #dict set opts -scheme info + set scheme_received 0 + } else { + set scheme_received 1; #so we know not to override caller's explicit choice } set querycommand [dict get $values commandpath] set queryargs [dict get $values subcommand] #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented if {[string match ::* $querycommand]} { set targetns [nsprefix $querycommand] set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global + #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global #when arginfo given a fully qualified path - we only want an answer for that exact command set nscommands [info commands ${targetns}::*] if {[lsearch -exact $nscommands $querycommand] >= 0} { @@ -2051,14 +2661,14 @@ tcl::namespace::eval punk::ns { set resolved $querycommand } } else { - #fully qualified command specified but doesn't exist + #fully qualified command specified but doesn't exist set origin $querycommand set resolved $querycommand } } else { #relative comandpath if {[string match (autodef)* $querycommand]} { - #pass through - should be found with id lookup + #pass through - should be found with id lookup set origin $querycommand set resolved $querycommand } else { @@ -2091,6 +2701,9 @@ tcl::namespace::eval punk::ns { ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] if {$nscaller ne "::"} { + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] } @@ -2104,9 +2717,32 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { + #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { - return [uplevel 1 [list punk::args::usage {*}$opts $origin]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } } } } @@ -2116,7 +2752,7 @@ tcl::namespace::eval punk::ns { switch -- $initial_cmdtype { na - alias { #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) + #consider using which_alias (wiki) set tgt [interp alias "" $origin] if {$tgt eq ""} { set tgt [interp alias "" [string trimleft $origin :]] @@ -2133,9 +2769,12 @@ tcl::namespace::eval punk::ns { #(possible curried arguments) #review - curried arguments could be for ensembles! set targetword $word1 - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] #puts "ALIAS THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] } @@ -2167,9 +2806,33 @@ tcl::namespace::eval punk::ns { #REVIEW - this doesn't cater for prefix callable subcommands set argcopy $queryargs if {[llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "====>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists [list $id {*}$queryargs]]} { - return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + } } } #while {[llength $argcopy]} { @@ -2182,21 +2845,46 @@ tcl::namespace::eval punk::ns { #didn't find any exact matches #traverse from other direction taking prefixes into account - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists $id]} { #cycle forward through leading values - set spec [punk::args::get_spec $id] + set specid $id + set specargs $queryargs if {[llength $queryargs]} { - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + #jjj + set spec [punk::args::get_spec $id] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs set queryargs_untested $queryargs foreach q $queryargs { - if {[llength [dict get $spec LEADER_NAMES]]} { - set subitems [dict get $spec LEADER_NAMES] + if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + set subitems [dict get $spec FORMS $fid LEADER_NAMES] if {[llength $subitems]} { set next [lindex $subitems 0] - set arginfo [dict get $spec ARG_INFO $next] + set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - set allchoices [list] + set allchoices [list] set choices [punk::args::system::Dict_getdef $arginfo -choices {}] set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] if {[dict exists $choicegroups ""]} { @@ -2214,18 +2902,45 @@ tcl::namespace::eval punk::ns { lappend nextqueryargs $resolved_q lpop queryargs_untested 0 if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - #set numvals [expr {[llength $queryargs]+1}] + #we have our first difference - recurse with new query args + #set numvals [expr {[llength $queryargs]+1}] #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - return [ punk::ns::arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested] + if {!$scheme_received} { + dict unset opts -scheme + } + return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] } #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list $id {*}$nextqueryargs] + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] if {[punk::args::id_exists $currentid]} { set spec [punk::args::get_spec $currentid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] } else { #We can get no further with custom defs #It is possible we have a documented lower level subcommand but missing the intermediate @@ -2242,8 +2957,34 @@ tcl::namespace::eval punk::ns { } } } else { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs } } @@ -2261,10 +3002,10 @@ tcl::namespace::eval punk::ns { #the call: info object methods -all # seems to do the right thing as far as hiding unexported methods, and showing things like destroy # - which don't seem to be otherwise easily introspectable - set public_methods [info object methods $origin -all] + set public_methods [info object methods $origin -all] #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - + if {[llength $queryargs]} { set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { @@ -2277,13 +3018,13 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} new" -help\ "create object with specified command name. Arguments are passed to the constructor." - @values + @values }] set i 0 foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2294,7 +3035,31 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin new"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin new"] + } } create { set constructorinfo [info class constructor $origin] @@ -2304,7 +3069,7 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} create" -help\ "create object with specified command name. Arguments following objectName are passed to the constructor." - @values -min 1 + @values -min 1 objectName -type string -help\ "possibly namespaced name for object instance command" }] @@ -2312,7 +3077,7 @@ tcl::namespace::eval punk::ns { foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2323,29 +3088,77 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin create"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin create"] + } } destroy { #review - generally no doc # but we may want notes about a specific destructor set argdef [punk::lib::tstr -return string { - @id -id "(audodef)${$origin} destroy" + @id -id "(autodef)${$origin} destroy" @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." @values -min 0 -max 0 }] punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + } } default { - #use info object call to resolve callchain + #use info object call to resolve callchain #we assume the first impl is the topmost in the callchain # and its call signature is therefore the one we are interested in - REVIEW # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? set implementations [::info object call $origin $c1] - #result documented as list of 4 element lists - #set callinfo [lindex $implementations 0] + #result documented as list of 4 element lists + #set callinfo [lindex $implementations 0] set oodef "" foreach impl $implementations { lassign $impl generaltype mname location methodtype @@ -2396,7 +3209,7 @@ tcl::namespace::eval punk::ns { switch -- [llength $a] { 1 { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2422,6 +3235,7 @@ tcl::namespace::eval punk::ns { } } set choicelabeldict [dict create] + set choiceinfodict [dict create] foreach cmd $public_methods { switch -- $cmd { new - create - destroy { @@ -2437,13 +3251,16 @@ tcl::namespace::eval punk::ns { if {$location eq "object"} { #set id "[string trimleft $origin :] $cmd" ;# " " set id "$origin $cmd" + dict set choiceinfodict $cmd {{doctype ooo}} } else { #set id "[string trimleft $location :] $cmd" ;# " " set id "$location $cmd" + dict set choiceinfodict $cmd {{doctype ooc}} } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { - dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + dict lappend choiceinfodict $cmd {doctype punkargs} } } break @@ -2451,6 +3268,7 @@ tcl::namespace::eval punk::ns { filter { } unknown { + dict set choiceinfodict $cmd {{doctype unknown}} } } } @@ -2458,11 +3276,11 @@ tcl::namespace::eval punk::ns { } } - set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review + set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" set idauto "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$idauto} + @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @leaders -min 1 @@ -2492,6 +3310,7 @@ tcl::namespace::eval punk::ns { #presumably -choiceprefix should be zero in that case?? set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] set prefixes [dict get $ensembleinfo -prefixes] set map [dict get $ensembleinfo -map] set ns [dict get $ensembleinfo -namespace] @@ -2537,54 +3356,142 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] if {[llength $queryargs]} { - set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs } - } - - set namespaces [list] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set ns [::namespace which $subwhat] - if {$ns ni $namespaces} { - lappend namespaces $ns + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + if {!$scheme_received} { + dict unset opts -scheme + } + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #use tailcall so %caller% is reported properly in error msg + tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + } } } + set have_usageinfo [list] set is_ensemble [list] set is_object [list] - foreach ns $namespaces { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin [nsprefix $ns] *]] 0] - lappend have_usageinfo {*}[dict get $nsinfo usageinfo] - lappend is_ensemble {*}[dict get $nsinfo ensembles] - lappend is_object {*}[dict get $nsinfo ooobjects] + set is_class [list] + set is_native [list] + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + if {$targettail in [dict get $nsinfo usageinfo]} { + lappend have_usageinfo $sub + } + if {$targettail in [dict get $nsinfo ensembles]} { + lappend is_ensemble $sub + } + if {$targettail in [dict get $nsinfo ooobjects]} { + lappend is_object $sub + } + if {$targettail in [dict get $nsinfo ooclasses]} { + lappend is_class $sub + } + if {$targettail in [dict get $nsinfo native]} { + lappend is_native $sub + } } + #todo - synopsis? set choicelabeldict [dict create] + + set choiceinfodict [dict create] foreach sub $subcommands { + + if {$sub in $is_ensemble} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + + if {$sub in $is_object} { + if {$sub in $is_class} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$sub in $is_native} { + dict lappend choiceinfodict $sub {doctype native} + } + if {$sub in $have_usageinfo} { - dict set choicelabeldict $sub " [Usageinfo_mark brightgreen]" - } elseif {$sub in $is_ensemble} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" - } elseif {$sub in $is_object} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" + #dict set choiceinfodict $sub [list {doctype punkargs}] + dict lappend choiceinfodict $sub {doctype punkargs} } } - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] set autoid "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} + @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @leaders -min 1 }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } + } append argdef \n $vline punk::args::define $argdef - return [punk::args::usage {*}$opts $autoid] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { + # parsing error e.g Bad number of leading values + #override -scheme in opts with -scheme error + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] + } + #return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2650,14 +3557,41 @@ tcl::namespace::eval punk::ns { } if {[llength $queryargs]} { - #todo - something better - set msg "Undocumented or nonexistant subcommand $origin $queryargs" + #todo - something better ? + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + + if {[punk::args::id_exists $origin]} { + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } + } + set msg "Undocumented or nonexistant command $origin $queryargs" append msg \n "$origin Type: $cmdtype" } else { if {$cmdtype eq "proc"} { set msg "Undocumented proc $origin" append msg \n "No argument processor detected" - append msg \n "function signature: $resolved $argl" + append msg \n "function signature: $resolved $argl" } else { set msg "Undocumented command $origin. Type: $cmdtype" } @@ -2667,15 +3601,15 @@ tcl::namespace::eval punk::ns { #todo - package up as navns proc corp {path} { - #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp + #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) if {[info exists punk::console::tabwidth]} { set tw $::punk::console::tabwidth } else { - set tw 8 + set tw 8 } - set indent [string repeat " " $tw] ;#match - #set indent [string repeat " " $tw] ;#A more sensible default for code - review + set indent [string repeat " " $tw] ;#match + #set indent [string repeat " " $tw] ;#A more sensible default for code - review if {[info exists ::auto_index($path)]} { set body "\n${indent}#corp# auto_index $::auto_index($path)" @@ -2695,7 +3629,7 @@ tcl::namespace::eval punk::ns { } #puts stderr "corp upns:$upns" - #set name [string trim $name :] + #set name [string trim $name :] #set origin [namespace origin ${upns}::$name] set origin [nseval $targetns [list ::namespace origin $name]] set resolved [nseval $targetns [list ::namespace which $name]] @@ -2703,7 +3637,7 @@ tcl::namespace::eval punk::ns { #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! if {$origin ni [info procs $origin]} { - #It seems an interp alias of "::x"" behaves the same as "x" + #It seems an interp alias of "::x"" behaves the same as "x" #But we can't create both at the same time - and they have to be queried by the exact name. #So we query for alias with and without leading :: set alias_qualified [interp alias {} [string trim $origin :]] @@ -2727,7 +3661,7 @@ tcl::namespace::eval punk::ns { #depending on number of aliases in the chain return [list alias {*}$alias] } - } + } if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { append body \n "${indent}#corp# namespace origin $origin" } @@ -2737,7 +3671,7 @@ tcl::namespace::eval punk::ns { } if {![catch {package require textutil::tabify} errpkg]} { set bodytext [info body $origin] - #punk::lib::indent preserves trailing empty lines - unlike textutil version + #punk::lib::indent preserves trailing empty lines - unlike textutil version set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] append body [punk::lib::indent $bodytext $indent] } else { @@ -2880,17 +3814,17 @@ tcl::namespace::eval punk::ns { set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] if {!$ns_populated} { - #we will catch-run an auto_index entry if any - #auto_index entry may or may not be prefixed with :: + #we will catch-run an auto_index entry if any + #auto_index entry may or may not be prefixed with :: set keys [list] #first look for exact pkg_unqualified and ::pkg_unqualified #leave these at beginning of keys list if {[array exists ::auto_index($pkg_unqualified)]} { - lappend keys $pkg_unqualified - } + lappend keys $pkg_unqualified + } if {[array exists ::auto_index(::$pkg_unqualified)]} { - lappend keys ::$pkg_unqualified - } + lappend keys ::$pkg_unqualified + } #as auto_index is an array - we could get keys in arbitrary order set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]] lappend keys {*}$matches @@ -2902,8 +3836,8 @@ tcl::namespace::eval punk::ns { set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] while {!$ns_populated && $i < [llength $keys]} { #todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base - #e.g if we are loading ::x::y - #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc + #e.g if we are loading ::x::y + #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc set k [lindex $keys $i] set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { @@ -2916,7 +3850,7 @@ tcl::namespace::eval punk::ns { } incr i } - + } } } @@ -2924,7 +3858,7 @@ tcl::namespace::eval punk::ns { if {[llength $cmdargs]} { set binding {} #if {[info level] == 1} { - # #up 1 is global + # #up 1 is global # set get_vars [list info vars] #} else { # set get_vars [list info locals] @@ -2955,7 +3889,7 @@ tcl::namespace::eval punk::ns { } else { #A variable can show in the results for 'info vars' (or nsvars) but still not exist. e.g a 'variable x' declaration in the namespace where the variable has never been set } - } + } return [dict create vars $capturevars arrs $capturearrs] } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) } ] @@ -2963,7 +3897,7 @@ tcl::namespace::eval punk::ns { set arglist [lassign $cmdargs scriptblock] if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} { - #one liner without use of $args + #one liner without use of $args append scriptblock { {*}$args} #tailcall apply [list args [string cat $scriptblock { {*}$args}] $ns] {*}$arglist } @@ -3043,7 +3977,7 @@ tcl::namespace::eval punk::ns { error "nsimport_noclobber error namespace $source_ns not found" } - set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] + set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] set a_commands [info commands $pat] #puts "-->commands:'$a_commands'" set a_tails [lmap v $a_commands {tcl::namespace::tail $v}] @@ -3053,11 +3987,11 @@ tcl::namespace::eval punk::ns { foreach m $matches { #we will be using namespace import one by one on commands. #we must protect glob chars that may exist in the actual command names. - #e.g nsimport_noclobber ::punk::ansi::a? + #e.g nsimport_noclobber ::punk::ansi::a? # will import a+ and a? #but nsimport_noclobber {::punk::ansi::a\?} # must import only a? - set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] + set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] if {$m ni $a_exported_tails} { lappend a_exported_tails $m } @@ -3071,7 +4005,7 @@ tcl::namespace::eval punk::ns { set imported_commands [list] if {[namespace exists $nstemp]} { namespace delete $nstemp - } + } namespace eval $nstemp {} foreach e $a_exported_tails { set imported [apply {{tgtns func srcns pfx tmpns} { @@ -3151,13 +4085,13 @@ tcl::namespace::eval punk::ns { @id -id ::i+ @cmd -name "i+" -help\ "Display command help side by side" - @values - cmds -multiple 1 -help\ + @values + cmd -multiple 1 -help\ "Command names for which to show help info" } interp alias {} i+ {}\ .=args> punk::args::get_by_id ::i+ |argd>\ - .=>2 dict get values cmds |cmds>\ + .=>2 dict get values cmd |cmds>\ .=cmds>2 lmap c {i -return tableobject {*}$c} |objs>\ .=objs>2 lmap t {$t configure -show_vseps 0 -show_edge 1} |>\ .=objs>2 lmap t {$t print} |tables>\ @@ -3179,9 +4113,9 @@ tcl::namespace::eval punk::ns { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index d823a923..317fc9de 100644 --- a/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -174,7 +174,7 @@ tcl::namespace::eval punk::packagepreference { set is_exact 1 } else { set pkg [lindex $args 1] - set vwant [lrange $args 2 end] ;#rare - but version can be a list of options + set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index a39fceaf..2ab1fb01 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -100,8 +100,12 @@ namespace eval punk::repo { subcommand -type string -choicecolumns 8 -choicegroups { "frequently used commands" {${$maincommands}} "" {${$othercmds}} - } + } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} }] + #-choiceinfo { + # add {{doctype punkargs}} + # diff {{doctype punkargs}} + #} return $result } @@ -112,7 +116,7 @@ namespace eval punk::repo { # @id -id ::punk::repo::fossil_proxy # @cmd -name fossil -help "fossil executable # " - # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}} # } ""] lappend PUNKARGS [list { @@ -129,7 +133,7 @@ namespace eval punk::repo { @dynamic @id -id "::punk::repo::fossil_proxy diff" @cmd -name "fossil diff" -help "fossil diff" - @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} + @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} } ""] lappend PUNKARGS [list { #todo - remove this comment - testing dynamic directive @@ -137,7 +141,7 @@ namespace eval punk::repo { @id -id "::punk::repo::fossil_proxy add" @cmd -name "fossil add" -help "fossil add " - @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} } ""] #TODO #lappend PUNKARGS [list { @@ -145,7 +149,7 @@ namespace eval punk::repo { # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @cmd -name "fossil add" -help "fossil add # " - # @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # } ""] lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} diff --git a/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/bootsupport/modules/punk/zip-0.1.1.tm index 99bc359d..4ba74656 100644 --- a/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip { expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) | ($hour << 11) | ($min << 5) | ($sec >> 1)} } - + punk::args::define { + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -help\ + "Walk the directory structure starting at base/<-subpath> + and return a list of the files and folders encountered. + Resulting paths are relative to base unless -resultrelative + is supplied. + Folder names will end with a trailing slash. + " + -resultrelative -optional 1 -help\ + "Resulting paths are relative to this value. + Defaults to the value of base. If empty string + is given to -resultrelative the paths returned + are effectively absolute paths." + -emptydirs -default 0 -type boolean -help\ + "Whether to include directory trees in the result which had no + matches for the given fileglobs. + Intermediate dirs are always returned if there is a match with + fileglobs further down even if -emptdirs is 0. + " + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" -help\ + "May contain glob chars for folder elements" + @values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } proc walk {args} { #*** !doctools #[call [fun walk] [arg ?options?] [arg base]] #[para] Walk a directory tree rooted at base #[para] the -excludes list can be a set of glob expressions to match against files and avoid - #[para] e.g + #[para] e.g #[example { # punk::zip::walk -exclude {CVS/* *~.#*} library #}] #todo: -relative 0|1 flag? - set argd [punk::args::get_dict { - @id -id ::punk::zip::walk - @cmd -name punk::zip::walk -help\ - "Walk the directory structure starting at base/<-subpath> - and return a list of the files and folders encountered. - Resulting paths are relative to base unless -resultrelative - is supplied. - Folder names will end with a trailing slash. - " - -resultrelative -optional 1 -help\ - "Resulting paths are relative to this value. - Defaults to the value of base. If empty string - is given to -resultrelative the paths returned - are effectively absolute paths." - -emptydirs -default 0 -type boolean -help\ - "Whether to include directory trees in the result which had no - matches for the given fileglobs. - Intermediate dirs are always returned if there is a match with - fileglobs further down even if -emptdirs is 0. - " - -excludes -default "" -help "list of glob expressions to match against files and exclude" - -subpath -default "" -help\ - "May contain glob chars for folder elements" - @values -min 1 -max -1 - base - fileglobs -default {*} -multiple 1 - } $args] + set argd [punk::args::parse $args withid ::punk::zip::walk] set base [dict get $argd values base] set fileglobs [dict get $argd values fileglobs] set subpath [dict get $argd opts -subpath] @@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip { + punk::args::define { + @id -id ::punk::zip::Addentry + @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + @opts + -comment -default "" -help "An optional comment specific to the added file" + @values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } + # Addentry - was Mkzipfile -- # # FIX ME: should handle the current offset for non-seekable channels @@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip { #[para] You can provide a -comment for the file. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. - set argd [punk::args::get_dict { - @id -id ::punk::zip::Addentry - @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' - return a central directory file record" - @opts - -comment -default "" -help "An optional comment specific to the added file" - @values -min 3 -max 4 - zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" - base -help "base path for entries" - path -type file -help "path of file to add" - zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe - Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::Addentry] set zipchan [dict get $argd values zipchan] set base [dict get $argd values base] set path [dict get $argd values path] @@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip { # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) #### + + punk::args::define { + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" + @opts + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix. + " + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + " + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided. + Note that this will + " + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + + @values -min 1 -max -1 + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." + } + # zip::mkzip -- # # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt - # + # proc mkzip {args} { #todo - doctools - [arg ?globs...?] syntax? @@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip { #[para] If a file already exists, an error will be raised. #[para] Call 'punk::zip::mkzip' with no arguments for usage display. - set argd [punk::args::get_dict { - @id -id ::punk::zip::mkzip - @cmd -name punk::zip::mkzip\ - -help "Create a zip archive in 'filename'" - @opts - -offsettype -default "archive" -choices {archive file}\ - -help "zip offsets stored relative to start of entire file or relative to start of zip-archive - Only relevant if the created file has a script/runtime prefix. - " - -return -default "pretty" -choices {pretty list none}\ - -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none\ - -help "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs - " - -runtime -default ""\ - -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review) - " - -comment -default ""\ - -help "An optional comment for the archive" - -directory -default ""\ - -help "The new zip archive will scan for contents within this folder or current directory if not provided. - Note that this will - " - -base -default ""\ - -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" - -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - - @values -min 1 -max -1 - filename -type file -default ""\ - -help "name of zipfile to create" - globs -default {*} -multiple 1\ - -help "list of glob patterns to match. - Only directories with matching files will be included in the archive." - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::mkzip] set filename [dict get $argd values filename] if {$filename eq ""} { error "mkzip filename cannot be empty string" diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index 9f4e75ee..ebd18fc1 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -140,16 +140,18 @@ tcl::namespace::eval textblock { # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # "algorithm choice" - - punk::args::define { - @dynamic - @id -id ::textblock::use_hash - @cmd -name "textblock::use_hash" -help\ - "Hashing algorithm to use for framecache lookup. - 'none' may be slightly faster but less compact - when viewing textblock::framecache" - @values -min 0 -max 1 - hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} + namespace eval argdoc { + set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]} + punk::args::define { + @dynamic + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP} + } } proc use_hash {args} { #set argd [punk::args::get_by_id ::textblock::use_hash $args] @@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock { -size -type integer\ -default 15\ -optional 1\ - -range {1 15} + -range {1 ""} -direction -default horizontal\ -choices {horizontal vertical}\ -help\ - "When rainbow is in the colour list, - this also affects the direction of - colour changes" - @values -min 0 -max 2 + "Direction of character increments. + When rainbow is in the colour list, + the colour stripes will be oriented + in this direction. + " + @values -min 0 -max 1 colour -type list -default {} -optional 1 -help\ "List of Ansi colour names - e.g. testblock 10 {white Red} + e.g. testblock -size 10 {white Red} produces a block of character 10x10 with white text on red bacground @@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock { set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + if {$size <= 15} { + set charsubset [lrange $chars 0 $size-1] + } else { + set numsets [expr {int(ceil($size / 15.0))}] + set longset [concat {*}[lrepeat $numsets $chars]] + set charsubset [lrange $longset 0 $size-1] + + set longbows [concat {*}[lrepeat $numsets $rainbow_list]] + set rainbow_list [lrange $longbows 0 $size-1] + } if {"noreset" in $colour} { set RST "" } else { @@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock { append row $c } append row $RST - append block $row\n + append block $row \n } set block [tcl::string::trimright $block \n] return $block } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST + if {$direction eq "vertical"} { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block + } else { + set block "" + for {set r 0} {$r < $size} {incr r} { + append block [::join $charsubset ""] \n + } + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block } - return $block } } interp alias {} testblock {} textblock::testblock @@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock { proc ::textblock::join1 {args} { - lassign [punk::args::get_dict { + lassign [punk::args::parse $args withdef { + @id -id ::textblock::join1 -ansiresets -default 1 -type integer blocks -type string -multiple 1 - } $args] _l leaders _o opts _v values + }] _l leaders _o opts _v values set blocks [tcl::dict::get $values blocks] set idx 0 @@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock { #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner #" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::textblock::join_basic2 -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -ansiresets -type any -default auto blocks -type any -multiple 1 - } $args] + }] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock { #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #they may however still be 'ragged' ie differing line lengths proc ::textblock::join {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - #-ansireplays is always on (if ansi detected) #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets @@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock { } proc ::textblock::join2 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock { } # This calls textblock::pad per cell :/ proc ::textblock::join3 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock { NOTE: more options available - argument definition is incomplete" @opts - -return -choices {table tableobject} + -return -default table -choices {table tableobject} -rows -type list -default "" -help\ "A list of lists. Each toplevel element represents a row. @@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock { -help "restrict to keys matching memberglob." }] #append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args + punk::args::parse $args withdef $spec return } diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index 3e82858e..8991b7fc 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.0.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application argparsingtest 999999.0a1.0 # Meta platform tcl -# Meta license MIT +# Meta license MIT # @@ Meta End @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_argparsingtest 0 999999.0a1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require argparsingtest] #[keywords module] #[description] @@ -106,7 +106,7 @@ namespace eval argparsingtest { #*** !doctools #[subsection {Namespace argparsingtest}] - #[para] Core API functions for argparsingtest + #[para] Core API functions for argparsingtest #[list_begin definitions] proc test1_ni {args} { @@ -277,8 +277,8 @@ namespace eval argparsingtest { #punk::args is slower than argp - but comparable, and argp doesn't support solo flags proc test1_punkargs {args} { set argd [punk::args::parse $args withdef { - @id -id ::argparsingtest::test1_punkargs - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -298,7 +298,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::test1_punkargs_by_id - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -320,7 +320,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::argparsingtest::test1_punkargs2 - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -334,7 +334,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -3 -default 3 -type integer @values - } + } proc test1_punkargs2 {args} { set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] return [tcl::dict::get $argd opts] @@ -342,9 +342,9 @@ namespace eval argparsingtest { proc test1_punkargs_validate_ansistripped {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs_validate_ansistripped - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string @@ -358,7 +358,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true @values - } $args] + }] return [tcl::dict::get $argd opts] } @@ -387,11 +387,11 @@ namespace eval argparsingtest { package require cmdline #cmdline::getoptions is much faster than typedGetoptions proc test1_cmdline_untyped {args} { - set cmdlineopts_untyped { - {return.arg "string" "return val"} + set cmdlineopts_untyped { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -405,11 +405,11 @@ namespace eval argparsingtest { return [::cmdline::getoptions args $cmdlineopts_untyped $usage] } proc test1_cmdline_typed {args} { - set cmdlineopts_typed { - {return.arg "string" "return val"} + set cmdlineopts_typed { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -465,7 +465,7 @@ namespace eval argparsingtest { #multiline values use first line of each record to determine amount of indent to trim proc test_multiline {args} { set t3 [textblock::frame t3] - set argd [punk::args::get_dict [subst { + set argd [punk::args::parse $args withdef [subst { -template1 -default { ****** * t1 * @@ -476,7 +476,7 @@ namespace eval argparsingtest { * t2 * ******} -template3 -default {$t3} - #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately + #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately -template3b -default { $t3 ----------------- @@ -491,20 +491,20 @@ namespace eval argparsingtest { " -flag -default 0 -type boolean - }] $args] + }]] return $argd } #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] - # return "ok" + # return "ok" #} @@ -524,14 +524,14 @@ namespace eval argparsingtest::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace argparsingtest::lib}] - #[para] Secondary functions that are part of the API + #[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 + # #[para]Description of utility1 + # return 1 #} @@ -549,17 +549,17 @@ namespace eval argparsingtest::lib { namespace eval argparsingtest::system { #*** !doctools #[subsection {Namespace argparsingtest::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide argparsingtest [namespace eval argparsingtest { variable pkg argparsingtest variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/patternpunk-1.1.tm b/src/modules/patternpunk-1.1.tm index cf73c712..bd3f44bd 100644 --- a/src/modules/patternpunk-1.1.tm +++ b/src/modules/patternpunk-1.1.tm @@ -346,7 +346,7 @@ _+ +_ package require punk::args set standard_frame_types [textblock::frametypes] set argd [punk::args::parse $args withdef [tstr -return string { - @id -id ">punk . deck" + @id -id "::>punk . deck" @cmd -name "deck" -help "Punk Deck mascot" -frame -default arc -choices "${$standard_frame_types}" -choicerestricted 0 -choiceprefix 1 -boxmap -default {} -type dict diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 6908f4c3..8f971e3b 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -6798,28 +6798,30 @@ namespace eval punk { return $linelist } - - punk::args::define { - @dynamic - @id -id ::punk::LOC - @cmd -name punk::LOC -help\ - "LOC - lines of code. - An implementation of a notoriously controversial metric" - -return -default showdict -choices {dict showdict} - -dir -default "\uFFFF" - -exclude_dupfiles -default 1 -type boolean - ${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]} - -antiglob_files -default "" -type list -help\ - "Exclude if file tail matches any of these patterns" - -exclude_punctlines -default 1 -type boolean - -show_largest -default 0 -type integer -help\ - "Report the top largest linecount files. - The value represents the number of files - to report on." - } " - #we could map away whitespace and use string is punct - but not as flexible? review - -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } - " + namespace eval argdoc { + set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]}} + punk::args::define { + @dynamic + @id -id ::punk::LOC + @cmd -name punk::LOC -help\ + "LOC - lines of code. + An implementation of a notoriously controversial metric" + -return -default showdict -choices {dict showdict} + -dir -default "\uFFFF" + -exclude_dupfiles -default 1 -type boolean + ${$DYN_ANTIGLOB_PATHS} + -antiglob_files -default "" -type list -help\ + "Exclude if file tail matches any of these patterns" + -exclude_punctlines -default 1 -type boolean + -show_largest -default 0 -type integer -help\ + "Report the top largest linecount files. + The value represents the number of files + to report on." + } " + #we could map away whitespace and use string is punct - but not as flexible? review + -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } + " + } #An implementation of a notoriously controversial metric. proc LOC {args} { set argd [punk::args::parse $args withid ::punk::LOC] diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index 4d5dcb1c..f2ddb1b6 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore { smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ config ::punk::config\ + s ::punk::ns::synopsis\ ] #*** !doctools diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index f2e08635..8a4725c2 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu foreach {pt code} $parts { switch -- [llength $codestack] { 0 { - append emit $base$pt$R + append emit $base $pt $R } 1 { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { - append emit $base$pt$R + append emit $base $pt $R set codestack [list] } else { #append emit [lindex $o_codestack 0]$pt if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } default { if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } @@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append emit $code } } - return $emit$R + return [append emit $R] } else { return $base$text$R } diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 224befcf..b22941b4 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -46,10 +46,10 @@ #[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 +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g #[example { # proc dofilestuff {args} { -# lassign [dict values [punk::args::get_dict { +# lassign [dict values [punk::args::parse $args withdef { # @cmd -help "do some stuff with files e.g dofilestuff " # @opts -type string # #comment lines ok @@ -58,7 +58,7 @@ # #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 +# }]] leaders opts values # # puts "translation is [dict get $opts -translation]" # foreach f [dict values $values] { @@ -66,25 +66,27 @@ # } # } #}] -#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls #[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values #[para]valid @ lines being with @cmd @leaders @opts @values #[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. #[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args call above may be something like: -#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} #[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments #[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments #[example { # proc dofilestuff {category args} { -# lassign [dict values [punk::args::get_dict { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff # -directory -default "" # -translation -default binary # -nocomplain -type none # @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 -# } $args]] leaders opts values +# }]] leaders opts values # puts "$category fileA: [dict get $values fileA]" # puts "$category fileB: [dict get $values fileB]" # } @@ -94,10 +96,10 @@ #[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 { +# punk::args::parse [list $category $another_leading_arg] withdef { # category -choices {cat1 cat2 cat3} # another_leading_arg -type boolean -# } [list $category $another_leading_arg] +# } #}] #*** !doctools @@ -239,13 +241,28 @@ tcl::namespace::eval punk::args::register { } # -- --- --- --- --- --- --- --- - 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 + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } #some packages, e.g punk::args::tclcore document other namespaces. #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages [dict create] + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } #*** !doctools #[list_end] [comment {--- end definitions namespace punk::args::register ---}] @@ -261,15 +278,33 @@ 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 rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } - variable argdata_cache [tcl::dict::create] + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } - variable id_counter 0 + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } #*** !doctools #[subsection {Namespace punk::args}] @@ -298,10 +333,17 @@ tcl::namespace::eval punk::args { #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 definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. - 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. @@ -315,11 +357,12 @@ tcl::namespace::eval punk::args { a table can be well worthwhile. For inner procs requiring utmost speed, the call can be made only on the unhappy path when basic processing determines a mismatch - or it can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... The definition should usually contain an initial line of the form: @id -id ::somecmd Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level begginning with the # character are ignored. + Similarly - lines at the top level beginning with the # character are ignored. All other toplevel lines must consist of a leading word followed by paired arguments. The arguments can be spread over multiple lines and contain lines of near-arbitrary text if they are properly braced or double quoted and Tcl escaping for inner quotes @@ -328,32 +371,37 @@ tcl::namespace::eval punk::args { (\\ 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. + parsing, defaults for subsequent arguments, and help display. directives include: %B%@id%N% ?opt val...? - spec-options: -id + directive-options: -id %B%@cmd%N% ?opt val...? - spec-options: -name -help + directive-options: -name -help %B%@leaders%N% ?opt val...? - spec-options: -min -max + directive-options: -min -max (used for leading args that come before switches/opts) %B%@opts%N% ?opt val...? - spec-options: -any + directive-options: -any %B%@values%N% ?opt val...? - spec-options: -min -max + directive-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%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) %B%@doc%N% ?opt val...? - spec-options: -name -url + directive-options: -name -url %B%@seealso%N% ?opt val...? - spec-options: -name -url (for footer - unimplemented) + directive-options: -name -url (for footer - unimplemented) - Some other spec-options normally present on custom arguments are available + Some other options normally present on custom arguments are available to use with the @leaders @opts @values directives to set defaults for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be + These 3 directives should occur in exactly this order - but can be repeated with custom argument lines interspersed. An @id line can only appear once and should be the first item. @@ -385,6 +433,7 @@ tcl::namespace::eval punk::args { a 'solo' flag ie accepts no value) int|integer list + indexexpression dict double bool|boolean @@ -423,7 +472,20 @@ tcl::namespace::eval punk::args { 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. + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. -choicerestricted Whether values not specified in -choices or -choicegroups are allowed. Defaults to true. @@ -439,12 +501,17 @@ tcl::namespace::eval punk::args { 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. + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). See for example the output if 'i zlib' where choices of the next subcommand are grouped by the names compression,channel, streaming and checksumming. The -choices list is equivalent to a -choicegroups dict entry where the key (groupname) is - the empty string. + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. -choicemultiple (default {1 1}) is a pair representing min and max number of choices that can be present in the value. @@ -520,6 +587,7 @@ tcl::namespace::eval punk::args { -multiple 0\ -regexprepass {}\ -validationtransform {}\ + -ensembleparameter 0\ ] set optspec_defaults [tcl::dict::create\ -type string\ @@ -534,6 +602,7 @@ tcl::namespace::eval punk::args { -multiple 0\ -regexprepass {}\ -validationtransform {}\ + -prefix 1\ ] set valspec_defaults [tcl::dict::create\ -type string\ @@ -557,60 +626,29 @@ tcl::namespace::eval punk::args { ARG_INFO [tcl::dict::create]\ ARG_CHECKS [tcl::dict::create]\ LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED {}\ - LEADER_NAMES {}\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ LEADER_MIN ""\ LEADER_MAX ""\ - leaderspec_defaults $leaderspec_defaults\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ LEADER_CHECKS_DEFAULTS {}\ - opt_default {}\ - opt_required {}\ - OPT_NAMES {}\ - opt_any {}\ - opt_solos {}\ - optspec_defaults $optspec_defaults\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ OPT_CHECKS_DEFAULTS {}\ - val_defaults {}\ - val_required {}\ - VAL_NAMES {}\ - val_min ""\ - val_max ""\ - valspec_defaults $valspec_defaults\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ VAL_CHECKS_DEFAULTS {}\ - argdisplay_info ""\ + FORMDISPLAY [tcl::dict::create]\ ] - #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} { @@ -621,16 +659,112 @@ tcl::namespace::eval punk::args { error todo } proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { dict get [resolve {*}$args] id } + proc resolve {args} { variable rawdef_cache variable id_cache_rawdef + set defspace "" if {[dict exists $rawdef_cache $args]} { - set id [dict get $rawdef_cache $args -id] - set is_dynamic [dict get $rawdef_cache $args -dynamic] + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } } else { + #should we really be resolving something that hasn't been defined? set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" set is_dynamic [rawdef_is_dynamic $args] dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] dict set id_cache_rawdef $id $args @@ -659,10 +793,13 @@ tcl::namespace::eval punk::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 {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 if {!$is_dynamic} { if {[tcl::dict::exists $argdata_cache $cache_key]} { @@ -674,17 +811,23 @@ tcl::namespace::eval punk::args { } 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]] + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } } } else { - #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]] + append optionspecs $pt [uplevel $LVL [list ::subst $param]] } } else { set normargs [list] @@ -692,21 +835,32 @@ tcl::namespace::eval punk::args { lappend normargs [tcl::string::map {\r\n \n} $a] } set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) if {[string first \$\{ $optionspecs] > 0} { set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel lassign $pt_params ptlist paramlist set optionspecs "" foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] + append optionspecs $pt [uplevel $LVL [list ::subst $param]] } tcl::dict::set argdefcache_unresolved $cache_key $pt_params } } #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { + if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] + return [tcl::dict::get $argdata_cache [list $optionspecs]] } } @@ -721,13 +875,11 @@ tcl::namespace::eval punk::args { #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 opt_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] - set val_defaults [tcl::dict::create] - set opt_solos [list] + #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] @@ -807,16 +959,16 @@ tcl::namespace::eval punk::args { 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 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 opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit set DEF_definition_id $id #form_defs @@ -960,18 +1112,21 @@ tcl::namespace::eval punk::args { 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??? - } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} } } } @@ -1030,24 +1185,31 @@ tcl::namespace::eval punk::args { doc { set doc_info [dict merge $doc_info $at_specs] } - argdisplay { - #override the displayed argument table. + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - set argdisplay_info [dict merge $argdisplay_info $at_specs] + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } } opts { foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "values"} { + if {[tcl::dict::get $F $fid argspace] eq "values"} { error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" } - dict set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid optspec_defaults] + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] foreach {k v} $at_specs { switch -- $k { + -form { + #review - handled above + } -any - -anyopts { - set opt_any $v + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v } -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { #review - only apply to certain types? @@ -1073,6 +1235,9 @@ tcl::namespace::eval punk::args { dict - dictionary { set v dict } + index { + set v indexexpression + } none - "" - - - any - ansistring - globstring - list { } @@ -1090,21 +1255,22 @@ tcl::namespace::eval punk::args { -regexprefail - -regexprefailmsg - -validationtransform - - -multiple { + -multiple - + -prefix { #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\ + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ } error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" } } } - dict set F $fid optspec_defaults $tmp_optspec_defaults + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults } ;# end foreach record_form_ids } leaders { @@ -1112,10 +1278,13 @@ tcl::namespace::eval punk::args { 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] + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] foreach {k v} $at_specs { switch -- $k { + -form { + #review - handled above + } -min - -minvalues { if {$v < 0} { @@ -1166,6 +1335,9 @@ tcl::namespace::eval punk::args { } list { + } + index { + set v indexexpression } default { #todo - disallow unknown types unless prefixed with custom- @@ -1184,8 +1356,13 @@ tcl::namespace::eval punk::args { -multiple { tcl::dict::set tmp_leaderspec_defaults $k $v } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } default { - set known { -min -minvalues -max -maxvalues\ + set known { -min -form -minvalues -max -maxvalues\ -minsize -maxsize -range\ -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ @@ -1196,7 +1373,7 @@ tcl::namespace::eval punk::args { } } } - dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults } ;#end foreach record_form_ids @@ -1205,25 +1382,28 @@ tcl::namespace::eval punk::args { foreach fid $record_form_ids { dict set F $fid argspace "values" - set tmp_valspec_defaults [dict get $F $fid valspec_defaults] + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] foreach {k v} $at_specs { switch -- $k { -form { + #review - handled above } -min - -minvalues { if {$v < 0} { error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" } - set val_min $v + #set val_min $v + dict set F $fid VAL_MIN $v } -max - -maxvalues { if {$v < -1} { error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" } - set val_max $v + #set val_max $v + dict set F $fid VAL_MAX $v } -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? @@ -1258,6 +1438,9 @@ tcl::namespace::eval punk::args { } list { + } + index { + set v indexexpression } default { #todo - disallow unknown types unless prefixed with custom- @@ -1277,7 +1460,7 @@ tcl::namespace::eval punk::args { tcl::dict::set tmp_valspec_defaults $k $v } default { - set known { -min -minvalues -max -maxvalues\ + set known { -min -form -minvalues -max -maxvalues\ -minsize -maxsize -range\ -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ -nocase\ @@ -1289,7 +1472,7 @@ tcl::namespace::eval punk::args { } } } - dict set F $fid valspec_defaults $tmp_valspec_defaults + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults } } @@ -1303,7 +1486,7 @@ tcl::namespace::eval punk::args { 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" + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" } } #record_type directive @@ -1313,8 +1496,6 @@ tcl::namespace::eval punk::args { 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" @@ -1345,19 +1526,33 @@ tcl::namespace::eval punk::args { lappend temp_leadernames $argname tcl::dict::set F $fid LEADER_NAMES $temp_leadernames } else { + #This can happen if the definition has repeated values error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" } if {[dict get $F $fid LEADER_MAX] >= 0} { - dict set F $fid LEADER_MAX [llength $temp_leadernames] + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } } } else { set record_type value tcl::dict::set argdef_values -ARGTYPE value set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } } } @@ -1370,12 +1565,12 @@ tcl::namespace::eval punk::args { foreach fid $record_form_ids { if {$is_opt} { - set spec_merged [dict get $F $fid optspec_defaults] + 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] + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] } else { - set spec_merged [dict get $F $fid leaderspec_defaults] + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] } } @@ -1401,13 +1596,15 @@ tcl::namespace::eval punk::args { dict - dictionary { tcl::dict::set spec_merged -type dict } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } "" - none { if {$is_opt} { tcl::dict::set spec_merged -type none if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. } - 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" @@ -1422,6 +1619,13 @@ tcl::namespace::eval punk::args { any - string - globstring { tcl::dict::set spec_merged -type [tcl::string::tolower $specval] } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } default { #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW tcl::dict::set spec_merged -type [tcl::string::tolower $specval] @@ -1438,6 +1642,14 @@ tcl::namespace::eval punk::args { #review -solo 1 vs -type none ? conflicting values? tcl::dict::set spec_merged $spec $specval } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } -validationtransform { #string is dict only 8.7/9+ if {[llength $specval] % 2} { @@ -1477,6 +1689,7 @@ tcl::namespace::eval punk::args { set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ ] error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" } @@ -1488,6 +1701,10 @@ tcl::namespace::eval punk::args { if {$is_opt} { tcl::dict::set F $fid ARG_CHECKS $argname\ [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } } else { tcl::dict::set F $fid ARG_CHECKS $argname\ [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize @@ -1496,26 +1713,31 @@ tcl::namespace::eval punk::args { #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 + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required } else { if {[dict get $F $fid argspace] eq "leaders"} { set temp_leader_required [dict get $F $fid LEADER_REQUIRED] lappend temp_leader_required $argname dict set F $fid LEADER_REQUIRED $temp_leader_required - #lappend leader_required $argname } else { - lappend val_required $argname + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required } } } if {[tcl::dict::exists $spec_merged -default]} { if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] } else { if {[dict get $F $fid argspace] eq "leaders"} { tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] } } } @@ -1530,7 +1752,7 @@ tcl::namespace::eval punk::args { #} - #check ALL forms not just form_ids_active (record_form_ids) + #now cycle through ALL forms not just form_ids_active (record_form_ids) dict for {fid formdata} $F { # REVIEW #no values specified - we can allow last leader to be multiple @@ -1539,10 +1761,22 @@ tcl::namespace::eval punk::args { 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 + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - 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" + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples } } @@ -1550,9 +1784,9 @@ tcl::namespace::eval punk::args { #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 + 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 } @@ -1594,44 +1828,20 @@ tcl::namespace::eval punk::args { 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\ + 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 argdata_cache [list $optionspecs] $argdata_dict } #tcl::dict::set id_cache_rawdef $DEF_definition_id $args @@ -1652,9 +1862,9 @@ tcl::namespace::eval punk::args { 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_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @argdisplay @seealso} + directives {@id @package @cmd @ref @doc @formdisplay @seealso} argumenttypes {leaders opts values} remaining_defaults {@leaders @opts @values} } @@ -1837,7 +2047,14 @@ tcl::namespace::eval punk::args { lappend globbed {*}$matches } set globbed [lsort -unique $globbed] - set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] set result "" set resultdict [dict create] @@ -1853,7 +2070,7 @@ tcl::namespace::eval punk::args { dict set resultdict @id [list -id [dict get $specdict id]] } } - foreach directive {@package @cmd @doc @seealso @argdisplay} { + foreach directive {@package @cmd @doc @seealso} { set dshort [string range $directive 1 end] if {"$directive" in $included_directives} { if {[dict exists $opt_override $directive]} { @@ -1865,22 +2082,26 @@ tcl::namespace::eval punk::args { } } } + + #todo @formdisplay + + #output ordered by leader, option, value foreach pseudodirective {leaders opts values} tp {leader option value} { set directive "@$pseudodirective" switch -- $directive { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} + @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]] + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] } else { - append result \n "$directive [dict get $specdict $defaults_key]" - dict set resultdict $directive [dict get $specdict $defaults_key] + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] } } @@ -1914,7 +2135,7 @@ tcl::namespace::eval punk::args { } } } - @package - @cmd - @doc - @seealso - @argdisplay { + @package - @cmd - @doc - @seealso { if {"$type" in $included_directives} { set tp [string range $type 1 end] ;# @package -> package if {[dict exists $opt_override $type]} { @@ -1925,21 +2146,22 @@ tcl::namespace::eval punk::args { dict set resultdict $type [dict get $specdict ${tp}_info] } } + #todo @formdisplay } @leaders - @opts - @values { #these are the active defaults for further arguments if {"$type" in $included_directives} { switch -- $type { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} + @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]] + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] } else { - append result \n "$type [dict get $specdict leaderspec_defaults]" - dict set resultdict $type [dict get $specdict leaderspec_defaults] + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] } } } @@ -1976,8 +2198,8 @@ tcl::namespace::eval punk::args { 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 deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$deflist] set arg_info [dict get $specdict ARG_INFO] set valnames [dict get $specdict VAL_NAMES] set result "" @@ -2006,9 +2228,11 @@ tcl::namespace::eval punk::args { #proc resolved_def_opts ?? proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} {return} - return [resolve {*}$rdef] + set deflist [raw_def $id] + if {$deflist eq ""} { + return + } + return [resolve {*}$deflist] #if {[id_exists $id]} { # return [resolve {*}[raw_def $id]] #} @@ -2118,6 +2342,7 @@ tcl::namespace::eval punk::args { return $id } else { set check_updates [list [namespace qualifiers $id]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" if {![llength [update_definitions $check_updates]]} { #nothing new loaded if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { @@ -2181,6 +2406,7 @@ tcl::namespace::eval punk::args { #scanned_packages (list) #namespace_docpackages (dict) proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" if {[set gposn [lsearch $nslist {}]] >= 0} { lset nslist $gposn :: } @@ -2202,7 +2428,7 @@ tcl::namespace::eval punk::args { 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 ( + #assert - if all are registered - then all have been scanned return {} } # -- --- --- --- --- --- @@ -2258,6 +2484,10 @@ tcl::namespace::eval punk::args { } else { set needed [list] foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } if {$pkgns in $registered && $pkgns ni $loaded_packages} { lappend needed $pkgns } @@ -2363,7 +2593,7 @@ tcl::namespace::eval punk::args { set caller [regexp -inline {\S+} $cmdinfo] if {$caller eq "namespace"} { # review - message? - set cmdinfo "punk::args::get_dict called from namespace" + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" } return $cmdinfo } @@ -2376,7 +2606,7 @@ tcl::namespace::eval punk::args { @values -min 0 -max 0 }] proc test_get_dict {args} { - punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $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 @@ -2431,18 +2661,81 @@ tcl::namespace::eval punk::args { @opts -badarg -type string -help\ "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" -aserror -type boolean -help\ "If true, the usage table is raised as an error message, otherwise it is returned as a value." -return -choices {string table tableobject} -choicelabels { string "no table layout" tableobject "table object cmd" - table "full table laout" + table "full table layout" } -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" }] ] - #basic recursion blocker + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + variable arg_error_CLR + array set arg_error_CLR {} + set arg_error_CLR(errormsg) [a+ brightred] + set arg_error_CLR(title) "" + set arg_error_CLR(check) [a+ brightgreen] + set arg_error_CLR(solo) [a+ brightcyan] + set arg_error_CLR(choiceprefix) [a+ underline] + set arg_error_CLR(badarg) [a+ brightred] + set arg_error_CLR(goodarg) [a+ green strike] + set arg_error_CLR(goodchoice) [a+ reverse] + set arg_error_CLR(linebase_header) [a+ white] + set arg_error_CLR(cmdname) [a+ brightwhite] + set arg_error_CLR(groupname) [a+ bold] + set arg_error_CLR(ansiborder) [a+ bold] + set arg_error_CLR(ansibase_header) [a+ bold] + set arg_error_CLR(ansibase_body) [a+ white] + variable arg_error_CLR_nocolour + array set arg_error_CLR_nocolour {} + set arg_error_CLR_nocolour(errormsg) [a+ bold] + set arg_error_CLR_nocolour(title) [a+ bold] + set arg_error_CLR_nocolour(check) "" + set arg_error_CLR_nocolour(solo) "" + set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment + set arg_error_CLR_nocolour(goodarg) [a+ strike] + set arg_error_CLR_nocolour(cmdname) [a+ bold] + set arg_error_CLR_nocolour(linebase_header) "" + set arg_error_CLR_nocolour(linebase) "" + set arg_error_CLR_nocolour(ansibase_body) "" + variable arg_error_CLR_info + array set arg_error_CLR_info {} + set arg_error_CLR_info(errormsg) [a+ brightred bold] + set arg_error_CLR_info(title) [a+ brightyellow bold] + set arg_error_CLR_info(check) [a+ brightgreen bold] + set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_info(groupname) [a+ cyan bold] + set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] + set arg_error_CLR_info(ansibase_header) [a+ cyan] + set arg_error_CLR_info(ansibase_body) [a+ white] + variable arg_error_CLR_error + array set arg_error_CLR_error {} + set arg_error_CLR_error(errormsg) [a+ brightred bold] + set arg_error_CLR_error(title) [a+ brightcyan bold] + set arg_error_CLR_error(check) [a+ brightgreen bold] + set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_error(groupname) [a+ cyan bold] + set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] + set arg_error_CLR_error(ansibase_header) [a+ yellow] + set arg_error_CLR_error(ansibase_body) [a+ white] + + + #bas ic recursion blocker variable arg_error_isrunning 0 proc arg_error {msg spec_dict args} { #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. @@ -2462,7 +2755,7 @@ tcl::namespace::eval punk::args { #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} {} + #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} #only |?-x?|string|... is shown in the output table. #should be something like: # |arg | @@ -2475,14 +2768,6 @@ tcl::namespace::eval punk::args { # - 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} { @@ -2496,15 +2781,33 @@ tcl::namespace::eval punk::args { set arg_error_isrunning 1 set badarg "" + set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error set scheme error + set form 0 dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] switch -- $fullk { -badarg { set badarg $v } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } -aserror { if {![string is boolean -strict $v]} { set arg_error_isrunning 0 @@ -2522,9 +2825,12 @@ tcl::namespace::eval punk::args { } set returntype $v } + -form { + set form $v + } default { set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" } } } @@ -2538,53 +2844,43 @@ tcl::namespace::eval punk::args { set scheme na } } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + #hack some basics for now. #for coloured schemes - use bold as well as brightcolour in case colour off. - 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] + upvar ::punk::args::arg_error_CLR CLR 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) "" + variable arg_error_CLR_nocolour + array set CLR [array get arg_error_CLR_nocolour } 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] + variable arg_error_CLR_info + array set CLR [array get arg_error_CLR_info] } 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] + variable arg_error_CLR_error + array set CLR [array get arg_error_CLR_error] } na { } @@ -2629,13 +2925,18 @@ tcl::namespace::eval punk::args { 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 argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + #if {"$argdisplay_header$argdisplay_body" eq ""} { + # set is_custom_argdisplay 0 + #} else { + # set is_custom_argdisplay 1 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 set blank_header_col [list] @@ -2660,15 +2961,26 @@ tcl::namespace::eval punk::args { } #synopsis set synopsis "" - set form_info [dict get $spec_dict FORM_INFO] + 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 + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] } + append synopsis $form_synopsis \n } if {$synopsis ne ""} { - set synopsis [string range $synopsis 0 end-1] + set synopsis [string trimright $synopsis \n] lappend blank_header_col "" } @@ -2724,7 +3036,7 @@ tcl::namespace::eval punk::args { } if {$synopsis ne ""} { if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] } else { #todo lappend errlines "Synopsis:\n$synopsis" @@ -2764,10 +3076,12 @@ tcl::namespace::eval punk::args { #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 + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead @@ -2777,39 +3091,48 @@ tcl::namespace::eval punk::args { set A_PREFIXEND $RST } + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + set opt_names [list] set opt_names_display [list] - if {[llength [dict get $spec_dict OPT_NAMES]]} { + if {[llength [dict get $form_dict OPT_NAMES]]} { if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] + set trie [punk::trie::trieclass new {*}[dict get $form_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 "" + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 } 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 $c } - 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 [dict get $form_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] + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { # if {![string match -* $argname]} { # lappend leading_val_names [lpop trailing_val_names 0] # } else { @@ -2823,13 +3146,17 @@ tcl::namespace::eval punk::args { #} set leading_val_names_display $leading_val_names set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict ARG_INFO $arg] + set arginfo [dict get $form_dict ARG_INFO $arg] if {[dict exists $arginfo -default]} { set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { @@ -2878,6 +3205,7 @@ tcl::namespace::eval punk::args { set prefixmsg "" } set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] set formattedchoices [dict create] ;#use dict rather than array to preserve order append help " Choices$prefixmsg$casemsg" if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { @@ -2896,16 +3224,44 @@ tcl::namespace::eval punk::args { if {[dict size $choicelabeldict]} { dict for {groupname clist} $choicegroups { foreach c $clist { - set cdisplay $c + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } if {[dict exists $choicelabeldict $c]} { append cdisplay \n [dict get $choicelabeldict $c] } - dict lappend formattedchoices $groupname $cdisplay + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } } } } else { - set formattedchoices $choicegroups + #set formattedchoices $choicegroups #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } } } else { if {[catch { @@ -2942,11 +3298,24 @@ tcl::namespace::eval punk::args { 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]" + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" if {[dict exists $choicelabeldict $c]} { append cdisplay \n [dict get $choicelabeldict $c] } - dict lappend formattedchoices $groupname $cdisplay + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } } } } errM]} { @@ -2957,15 +3326,42 @@ tcl::namespace::eval punk::args { if {[dict size $choicelabeldict]} { dict for {groupname clist} $choicegroups { foreach c $clist { - set cdisplay $c + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } if {[dict exists $choicelabeldict $c]} { append cdisplay \n [dict get $choicelabeldict $c] } - dict lappend formattedchoices $groupname $cdisplay + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } } } } else { - set formattedchoices $choicegroups + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } } } @@ -3082,10 +3478,17 @@ tcl::namespace::eval punk::args { $t add_row [list $argshow $typeshow $default $multiple $help] if {$arg eq $badarg} { $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG } } else { #review - formatting will be all over the shop due to newlines in typesshow, help set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } foreach ln [split $help \n] { append arghelp " $ln" \n } @@ -3161,7 +3564,10 @@ 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 -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { @values -min 0 -max 1 id -help\ @@ -3169,13 +3575,15 @@ tcl::namespace::eval punk::args { Will usually match the command name" }] proc usage {args} { - lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received set id [dict get $values id] set real_id [real_id $id] if {$real_id eq ""} { error "punk::args::usage - no such id: $id" } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 } lappend PUNKARGS [list { @@ -3196,7 +3604,7 @@ tcl::namespace::eval punk::args { 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 + tailcall ::punk::args::get_dict $definitionlist $arglist } #consider @@ -3274,6 +3682,7 @@ tcl::namespace::eval punk::args { @values -min 2 @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 withid -type literal -help\ "The literal value 'withid'" id -type string -help\ @@ -3297,28 +3706,55 @@ tcl::namespace::eval punk::args { proc parse {args} { set tailtype "" ;#withid|withdef if {[llength $args] < 3} { - error "punk::args::parse - invalid call. < 3 args" + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse } - set parseargs [lindex $args 0] - set tailargs [lrange $args 1 end] + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] - 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" + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + #unhappy path - not enough options + #review - which form of punk::args::parse? + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] } else { - set tailtype withdef - } - } else { - set tailtype withid + break + } } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - 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" - } + + #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) @@ -3331,7 +3767,7 @@ tcl::namespace::eval punk::args { #todo - load override_errorstyle from configuration #dict set defaultopts -errorstyle $ - + #puts "def: $defaultopts opts: $opts" set opts [dict merge $defaultopts $opts] dict for {k v} $opts { switch -- $k { @@ -3339,16 +3775,18 @@ tcl::namespace::eval punk::args { } default { #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse } } } switch -- $tailtype { withid { - if {[llength [lrange $tailargs $split+1 end]] != 1} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse } - set id [lindex $tailargs $split+1] + set id [lindex $tailargs 0] #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" set deflist [raw_def $id] if {[llength $deflist] == 0} { @@ -3356,18 +3794,18 @@ tcl::namespace::eval punk::args { } } withdef { - set deflist [lrange $tailargs $split+1 end] + set deflist $tailargs if {[llength $deflist] < 1} { error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" } #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" } default { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" } } try { - set result [punk::args::get_dict {*}$deflist $parseargs] + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] } trap {PUNKARGS VALIDATION} {msg erroropts} { set opt_errorstyle [dict get $opts -errorstyle] @@ -3389,7 +3827,7 @@ tcl::namespace::eval punk::args { 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] + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] } return -options [list -code error -errorcode $ecode] $msg } @@ -3398,7 +3836,7 @@ tcl::namespace::eval punk::args { 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] + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] } return -options [list -code error -errorcode $ecode] $msg } @@ -3416,7 +3854,7 @@ tcl::namespace::eval punk::args { append msg \n [punk::lib::showdict -roottype list $estack */*] } if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] append msg \n "::errorCode summary: $ecode_summary" return -options [list -code error -errorcode $ecode] $msg } else { @@ -3430,6 +3868,10 @@ tcl::namespace::eval punk::args { puts stderr "errorstyle debug not implemented" return -options [list -code error -errorcode $ecode] $msg } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } } } trap {PUNKARGS} {msg erropts} { append msg \n "Unexpected PUNKARGS error" @@ -3497,24 +3939,34 @@ tcl::namespace::eval punk::args { #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} { + proc get_dict {deflist rawargs 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 ? + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } #*** !doctools - #[call [fun get_dict] [arg optionspecs] [arg rawargs]] + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values #[para]Returns a dict of the form: opts values #[para]ARGUMENTS: #[list_begin arguments] - #[arg_def 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 + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values #[para]Each optionspec line defining a flag must be of the form: #[para]-optionname -key val -key2 val2... @@ -3532,29 +3984,46 @@ tcl::namespace::eval punk::args { #[para] #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict { + #punk::args::get_dict [list { # @opts # -opt1 -default {} # -opt2 -default { # etc # } # @values -multiple 1 - #} $args + #}] $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] + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic #if definition has been seen before, #define will either return a permanently cached argspecs (-dynamic 0) - or # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] # ----------------------------------------------- # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) tcl::dict::with argspecs {} ;#turn keys into vars - # TODO - capitalise 'define' vars to make it a bit easier + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + #puts "-arg_info->$arg_info" set flagsreceived [list] ;#for checking if required flags satisfied @@ -3570,7 +4039,19 @@ tcl::namespace::eval punk::args { # -- --- --- --- # 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 + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + set pre_values {} set argnames [tcl::dict::keys $ARG_INFO] @@ -3645,7 +4126,7 @@ tcl::namespace::eval punk::args { #} #check if enough rawargs to fill any required values - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { break } else { lappend pre_values [lpop rawargs 0] @@ -3655,7 +4136,7 @@ tcl::namespace::eval punk::args { #required if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { + if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { break } } @@ -3666,8 +4147,22 @@ tcl::namespace::eval punk::args { } else { #unnamed leader if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN} { - break + if {$ridx > $LEADER_MIN-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } } else { #haven't reached LEADER_MIN lappend pre_values [lpop rawargs 0] @@ -3685,6 +4180,7 @@ tcl::namespace::eval punk::args { set argstate $ARG_INFO ;#argstate may have entries added set arg_checks $ARG_CHECKS + #JJJJ if {$LEADER_MIN eq ""} { set leadermin 0 } else { @@ -3696,30 +4192,39 @@ tcl::namespace::eval punk::args { set leadermax $LEADER_MAX } + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + #assert leadermax leadermin are numeric #assert - rawargs has been reduced by leading positionals + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + set leaders [list] set arglist {} set post_values {} - #val_min, val_max + #valmin, valmax #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} { + if {$valmax == -1} { set vals_total_possible [llength $rawargs] set vals_remaining_possible $vals_total_possible } else { - set vals_total_possible $val_max + set vals_total_possible $valmax 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} { + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { # if current arg is -- it will pass through as a value here set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] @@ -3729,10 +4234,10 @@ tcl::namespace::eval punk::args { #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} { + #remaining num args <= valmin already covered above + if {$valmax != -1} { #finite max number of vals - if {$remaining_args_including_this == $val_max} { + if {$remaining_args_including_this == $valmax} { #assume it's a value. set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] @@ -3753,6 +4258,21 @@ tcl::namespace::eval punk::args { } else { set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] if {$fullopt ne ""} { + if {![tcl::dict::get $argstate $fullopt -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { #non-solo #check if it was actually a value that looked like a flag @@ -3783,7 +4303,6 @@ tcl::namespace::eval punk::args { 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 @@ -3806,10 +4325,10 @@ tcl::namespace::eval punk::args { 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} { + #comparison to valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min + #we may need to lookahead by 2 regarding valmax valmin #even with optany - assume an unknown within the space of possible values is a value #unmatched option in right position to be considered a value - treat like eopts @@ -3818,10 +4337,10 @@ tcl::namespace::eval punk::args { set post_values [lrange $rawargs $i end] break } - if {$opt_any} { + 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 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]} { @@ -3886,13 +4405,42 @@ tcl::namespace::eval punk::args { #puts stderr "--> arglist: $arglist" #puts stderr "--> values: $values" + #--------------------------------------- + set ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) set ldridx 0 set in_multiple "" set leadernames_received [list] - set leaders_dict $LEADER_DEFAULTS + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + #test args parse_withdef_leader_stride - todo + #change to for loop foreach leadername $LEADER_NAMES ldr $leaders { if {$ldridx+1 > $num_leaders} { break @@ -3915,7 +4463,7 @@ tcl::namespace::eval punk::args { 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 argstate $positionalidx $LEADERSPEC_DEFAULTS tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS lappend leadernames_received $positionalidx } @@ -3924,82 +4472,118 @@ tcl::namespace::eval punk::args { incr positionalidx } + set validx 0 - set in_multiple "" + set valname_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 - } + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $val_defaults $valname]} { + 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 + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list } else { - tcl::dict::lappend values_dict $valname $val + tcl::dict::lappend values_dict $valname $strideval } - set in_multiple $valname + set valname_multiple $valname } else { - tcl::dict::set values_dict $valname $val + tcl::dict::set values_dict $valname $strideval } lappend valnames_received $valname } else { - if {$in_multiple ne ""} { - tcl::dict::lappend values_dict $in_multiple $val + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $in_multiple + lappend valnames_received $valname_multiple } else { tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $valspec_defaults + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS lappend valnames_received $positionalidx } } - incr validx - incr positionalidx + set positionalidx [expr {$start_position + $validx}] } + #------------------------------------------ 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} { + if {$valmax == -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 + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg } } else { - if {$num_values < $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 + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $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 + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg } } } @@ -4018,10 +4602,10 @@ tcl::namespace::eval punk::args { #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]]]} { + #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]]]} { + #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 @@ -4030,12 +4614,12 @@ tcl::namespace::eval punk::args { 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]]]} { + 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]]]} { + 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 @@ -4048,7 +4632,7 @@ tcl::namespace::eval punk::args { #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 + #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 { @@ -4090,6 +4674,24 @@ tcl::namespace::eval punk::args { set vlist_check $vlist } + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } #reduce our validation requirements by removing values which match defaultval or match -choices #(could be -multiple with -choicerestriction 0 where some selections match and others don't) if {$has_choices} { @@ -4116,17 +4718,6 @@ tcl::namespace::eval punk::args { #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] @@ -4151,11 +4742,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 %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg } if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg } #----------------------------------- @@ -4287,7 +4878,7 @@ tcl::namespace::eval punk::args { 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'" + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname } @@ -4325,9 +4916,8 @@ tcl::namespace::eval punk::args { #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]'" + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" } } } @@ -4345,13 +4935,20 @@ tcl::namespace::eval punk::args { #assert [llength $vlist] == [llength $vlist_check] if {[llength $vlist]} { switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } any {} list { foreach e_check $vlist_check { if {![tcl::string::is list -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - #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 { @@ -4359,17 +4956,15 @@ tcl::namespace::eval punk::args { -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]" + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - #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]" + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname } } } @@ -4378,6 +4973,14 @@ tcl::namespace::eval punk::args { } } } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks @@ -4413,10 +5016,9 @@ tcl::namespace::eval punk::args { #review - %caller% ?? set msg [tcl::dict::get $thisarg -regexprefailmsg] } else { - set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" } return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error $msg $argspecs -badarg $argname } } } @@ -4430,18 +5032,16 @@ tcl::namespace::eval punk::args { 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" + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - #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" + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname } } } @@ -4456,17 +5056,15 @@ tcl::namespace::eval punk::args { -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'" + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #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'" + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #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 } } } @@ -4475,6 +5073,46 @@ tcl::namespace::eval punk::args { } } } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } int { #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive if {[tcl::dict::exists $thisarg -range]} { @@ -4483,43 +5121,37 @@ tcl::namespace::eval punk::args { 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'" + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #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'" + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #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'" + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #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'" + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #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'" + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #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'" + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname } } } @@ -4527,9 +5159,8 @@ tcl::namespace::eval punk::args { } 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'" + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname } } } @@ -4537,9 +5168,8 @@ tcl::namespace::eval punk::args { 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'" + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" } if {[tcl::dict::size $thisarg_checks]} { #safe jumptable test @@ -4551,9 +5181,8 @@ tcl::namespace::eval punk::args { #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'" + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname } } } @@ -4564,18 +5193,16 @@ tcl::namespace::eval punk::args { 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'" + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #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'" + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #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 { @@ -4583,17 +5210,15 @@ tcl::namespace::eval punk::args { -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]" + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #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]" + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #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 } } } @@ -4616,14 +5241,9 @@ tcl::namespace::eval punk::args { 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'" + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error $msg $argspecs -badarg $argname } } } @@ -4635,25 +5255,22 @@ 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 ? - set msg "Option $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #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" + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #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" + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname } } } @@ -4662,9 +5279,8 @@ tcl::namespace::eval punk::args { #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" + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname } } } @@ -4719,14 +5335,307 @@ tcl::namespace::eval punk::args { return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] } - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + lappend PUNKARGS [list { @id -id ::punk::args::TEST @opts -optional 0 @@ -4782,6 +5691,42 @@ tcl::namespace::eval punk::args::lib { } } + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + #experiment with equiv of js template literals with ${expression} in templates #e.g tstr {This is the value of x in calling scope ${$x} !} @@ -5098,7 +6043,7 @@ tcl::namespace::eval punk::args::lib { } #test single placeholder tstr args where single placeholder must be an int proc tstr_test_one {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. example: set id 2 @@ -5110,7 +6055,7 @@ tcl::namespace::eval punk::args::lib { 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]] ""] diff --git a/src/modules/punk/args-buildversion.txt b/src/modules/punk/args-buildversion.txt index 7e019aff..ee099ef9 100644 --- a/src/modules/punk/args-buildversion.txt +++ b/src/modules/punk/args-buildversion.txt @@ -1,3 +1,3 @@ -0.1.4 +0.1.7 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index 6e7521a9..f373f9c1 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -141,17 +141,20 @@ tcl::namespace::eval punk::args::tclcore { variable PUNKARGS - package require punk::ansi - tcl::namespace::import ::punk::ansi::a+ - # -- --- --- --- --- - #non colour SGR codes - # we can use these directly via ${$I} etc without marking a definition with @dynamic - #This is because they don't need to change when colour switched on and off. - set I [a+ italic] - set NI [a+ noitalic] - set B [a+ bold] - set N [a+ normal] - # -- --- --- --- --- + namespace eval argdoc { + package require punk::ansi + tcl::namespace::import ::punk::ansi::a+ + tcl::namespace::import ::punk::args::tclcore::manpage_tcl + # -- --- --- --- --- + #non colour SGR codes + # we can use these directly via ${$I} etc without marking a definition with @dynamic + #This is because they don't need to change when colour switched on and off. + set I [a+ italic] + set NI [a+ noitalic] + set B [a+ bold] + set N [a+ normal] + # -- --- --- --- --- + } namespace eval argdoc { @@ -180,13 +183,15 @@ tcl::namespace::eval punk::args::tclcore { proc ensemble_subcommands_definition {args} { #args manually parsed - with use of argdef for unhappy-path only if {![llength $args]} { - punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition return } set ensemble [lindex $args end] set optlist [lrange $args 0 end-1] if {[llength $optlist] % 2} { - punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition return } set defaults [dict create\ @@ -198,7 +203,8 @@ tcl::namespace::eval punk::args::tclcore { switch -- $k { -groupdict - -columns {} default { - punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition return } } @@ -255,12 +261,30 @@ tcl::namespace::eval punk::args::tclcore { dict for {g members} $opt_groupdict { lappend allgrouped {*}$members } - foreach sc $allsubs { + set choiceinfodict [dict create] + foreach {sc cmd} $subdict { if {$sc ni $allgrouped} { if {$sc ni $others} { lappend others $sc } } + set cinfo [punk::ns::resolve_command {*}$cmd] + set tp [dict get $cinfo cmdtype] + + dict set choiceinfodict $sc [list [list resolved $cmd]] + + switch -- $tp { + ensemble - native { + dict lappend choiceinfodict $sc [list doctype $tp] + } + object { + dict lappend choiceinfodict $sc [list doctype oo] + } + } + + if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { + dict lappend choiceinfodict $sc {doctype punkargs} + } } set argdef "" @@ -269,7 +293,7 @@ tcl::namespace::eval punk::args::tclcore { dict for {g members} $opt_groupdict { append argdef " \"$g\" \{$members\}" \n } - append argdef " \} -choicecolumns $opt_columns" \n + append argdef " \} -choicecolumns $opt_columns -choiceinfo {$choiceinfodict}" \n #todo -choicelabels #detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. @@ -301,7 +325,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { #test of @form - @id -id ::AFTER + @id -id ::after @cmd -name "Builtin: after" -help\ "Execute a command after a time delay." @@ -310,19 +334,23 @@ tcl::namespace::eval punk::args::tclcore { "script argument to be concatenated in the same fashion as the concat command" # ---------- shared elements ------------- - @form -form {delay} -synopsis "after ms" + #@form -form {delay} -synopsis "after ms" + @form -form {delay} @form -form {schedule_ms} -synopsis "after ms ?script...?" - #@values -form {*} #note "classify next argument as a value not a leader" + #review + #@values -form {*} #note "classify next argument as a value not a leader" + #@values -form {*} + ms -form {*} -type int -help\ "milliseconds" @values -form {delay} -min 1 -max 1 @values -form {schedule_ms} -min 2 - script -form {schedule_ms} -multiple 1 -optional 1 ref-help common_script_help + script -form {schedule_ms} -multiple 1 -optional 0 ref-help common_script_help @form -form {cancelid} -synopsis "after cancel id" - @values + @values -min 2 -max 2 cancel -choices {cancel} id @@ -334,17 +362,108 @@ tcl::namespace::eval punk::args::tclcore { @form -form {schedule_idle} -synopsis "after idle script ?script...?" - @values -min 1 + @values -min 2 idle -choices {idle} - script -multiple 1 -optional 1 ref-help common_script_help + script -multiple 1 -optional 0 ref-help common_script_help @form -form {info} -synopsis "after info ?id?" + @values -min 0 -max 2 info -choices {info} id -optional 1 } "@doc -name Manpage: -url [manpage_tcl after]" ] namespace eval argdoc { + punk::args::define { + @id -id ::tcl::info::args + @cmd -name "BUILTIN: tcl::info::args" -help\ + "Returns the names of the parameters to the procedure named ${$I}procname${$NI}." + @values -min 1 -max 1 + procname -type string -optional 0 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::body + @cmd -name "BUILTIN: tcl::info::body" -help\ + "Returns the body procedure named ${$I}procname${$NI}." + @values -min 1 -max 1 + procname -type string -optional 0 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::default + @cmd -name "BUILTIN: tcl::info::default" -help\ + "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} + has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. + Otherwise, returns ${$B}0${$N}." + @values -min 3 -max 3 + procname -type string -optional 0 + parameter + varname + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::cmdtype + @cmd -name "Builtin: tcl::info::cmdtype" -help\ + "Returns the type of the command named ${$I}commandName${$NI}. + Built-in types are: + ${$B}alias${$N} + ${$I}commandName${$NI} was created by 'interp alias'. In a safe interpreter an + alias is only visible if both the alias and the target are visible. + ${$B}coroutine${$N} + ${$I}commandName${$NI} was created by 'coroutine'. + ${$B}ensemble${$N} + ${$I}commandName${$NI} was created by 'namespace ensemble'. + ${$B}import${$N} + ${$I}commandName${$NI} was created by 'namespace import'. + ${$B}native${$N} + ${$I}commandName${$NI} was created by the 'Tcl_CreateObjCommand' interface + directly without further registration of the type of command. + ${$B}object${$N} + ${$I}commandName${$NI} is the public comand that represents an instance + of oo::object or one of its subclasses. + ${$B}privateObject${$N} + ${$I}commandName${$NI} is the private command, my by default, + that represents an instance of oo::object or one of its subclasses. + ${$B}proc${$N} + ${$I}commandName${$NI} was created by 'proc'. + ${$B}interp${$N} + ${$I}commandName${$NI} was created by 'interp create'. + ${$B}zlibStream${$N} + ${$I}commandName${$NI} was created by 'zlib stream'. + " + @values -min 1 -max 1 + commandName -type string + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::oo::InfoObject::call + @cmd -name "Builtin: oo::InfoObject::call" -help\ + "Returns a description of the method implementations that are used to provide + ${$I}object's${$NI} implementation of ${$I}method${$NI}. This consists of a + list of lists of four elements, where each sublist consists of: + element 0: a word that describes the general type of method implementation, being + one of + ${$B}method${$N} for an ordinary method, ${$B}filter${$N} for an applied filter, + ${$B}private${$N} for a private method, and ${$B}unknown${$N} for a method that + is invoked as part of unknown method handling. + element 1: a word giving the name of the particular method invoked (which is always + the same as method for the ${$B}method${$N} type, and \"${$B}unknown${$N}\" + for the ${$B}unknown${$N} type) + element 2: a word giving what defined the method (the fully qualified name of the + class, or the literal string ${$B}object${$N} if the method implementation is on + an instance) + element 3: a word describing the type of method implementation + (see ${$B}info object methodtype${$N} + + Note that there is no inspection of whether the method implementations actually use + ${$B}next${$N} to transfer control along the call chain, and the call chains that + this command files do not actually contain private methods." + @values -min 2 -max 2 + object + method + } "@doc -name Manpage: -url [manpage_tcl info]" + #todo - make generic - take command and known_groups_dict proc info_subcommands {} { #package require punk::ns @@ -357,17 +476,18 @@ tcl::namespace::eval punk::args::tclcore { return [ensemble_subcommands_definition -groupdict $groups -columns 4 info] } + set DYN_INFO_SUBCOMMANDS {${[punk::args::tclcore::argdoc::info_subcommands]}} + lappend PUNKARGS [list { + @dynamic + @id -id ::info + @cmd -name "Builtin: info" -help\ + "Information about the state of the Tcl interpreter" + @leaders -min 1 -max 1 + ${$DYN_INFO_SUBCOMMANDS} + @values -min 0 + + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl array]" ] } - lappend PUNKARGS [list { - @dynamic - @id -id ::info - @cmd -name "Builtin: info" -help\ - "Information about the state of the Tcl interpreter" - @leaders -min 1 -max 1 - ${[punk::args::tclcore::argdoc::info_subcommands]} - @values -min 0 - - } "@doc -name Manpage: -url [manpage_tcl array]" ] @@ -396,6 +516,7 @@ tcl::namespace::eval punk::args::tclcore { } ] lappend PUNKARGS [list { @id -id "::tcl::binary::decode::base64" + @default -id (default)::tcl::binary::*::base64 @cmd -name "binary decode base64" -strict -type none -help\ "Instructs the decoder to throw an error if it encounters any characters that @@ -429,7 +550,7 @@ tcl::namespace::eval punk::args::tclcore { characters. Otherwise it ignores them." @values -min 1 -max 1 data -type string - } "@doc -name Manpage: -url [manpage_tcl binary]" ] + }] lappend PUNKARGS [list { @@ -474,6 +595,23 @@ tcl::namespace::eval punk::args::tclcore { data -type string } ] + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::dirs" + @cmd -name "encoding dirs" -help\ + "Tcl can load encoding data files from the file system that describe + additional encodings for it to work with. This command sets the search + path for ${$B}*.enc${$N} encoding data files to the list of directories + ${$I}directoryList${$NI}. If ${$I}directoryList${$NI} is omitted then the + command returns the current list of directories that make up the search + path. It is an error for ${$I}directoryList${$NI} to not be a valid list. + If, when a search for an encoding data file is happening, an element in + ${$I}directoryList${$NI} does not refer to a readable, searchable + directory, that element is ignored." + @values -min 0 -max 1 + directoryList -optional 1 -type list + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } lappend PUNKARGS [list { @id -id ::time @@ -491,6 +629,119 @@ tcl::namespace::eval punk::args::tclcore { count -type integer -default 1 -optional 1 } "@doc -name Manpage: -url [manpage_tcl time]" ] + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tcl::chan::blocked + @cmd -name "Builtin: tcl::chan::blocked" -help\ + "This tests whether the last input operation on the channel called ${$I}channel${$NI} + failed because it would otherwise have caused the process to block, and returns 1 + if that was the case. It returns 0 otherwise. Note that this only ever returns 1 + when the channel has been configured to be non-blocking; all Tcl channels have + blocking turned on by default" + @values -min 1 -max 1 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + #close + lappend PUNKARGS [list { + @id -id ::fconfigure + @cmd -name "Builtin: chan configure" -help\ + "Query or set the configuration options of the channel named ${$I}channel${$NI} + If no ${$I}optionName${$NI} or ${$I}value${$NI} arguments are supplied, the + command returns a list containing alternating option names and values for the + channel. If ${$I}optionName${$NI} is supplied but no ${$I}value${$NI} then the + command returns the current value of the given option. If one or more pairs + of ${$I}optionName${$NI} and ${$I}value${$NI} are supplied, the command sets each + of the named options to the corresponding value; in this case the return + value is an empty string. + + The options described below are supported for all channels. In addition, each + channel type may add options that only it supports. See the manual entry for + the command that creates each type of channel for the options supported by + that specific type of channel. For example, see the manual entry for the + ${$B}socket${$N} command for additional options for sockets, and the ${$B}open${$N} + command for additional options for serial devices. + ${$B}-blocking${$N} ${$I}boolean${$NI} + The ${$B}-blocking${$N} option determines whether I/O operations on the + channel can cause the process to block indefinitely. The value of the + option must be a proper boolean value. Channels are normally in blocking + mode; if a channel is placed into non-blocking mode it will affect the + operation of the ${$B}chan gets, chan read, chan puts, chan flush,${$N} + and ${$B}chan close${$N} commands; see the documentation for those + commands for details. For non-blocking mode to work correctly, the + application must be using the Tcl event loop (e.g. by calling + ${$B}Tcl_DoOneEvent${$N} or invoking the ${$B}vwait${$N} command). + ${$B}-buffering${$N} ${$I}newValue${$NI} + + ${$B}-buffersize${$N} ${$I}newSize${$NI} + + ${$B}-encoding${$N} ${$I}name${$NI} + + ${$B}-eofchar${$N} ${$I}char${$NI} + + ${$B}-profile${$N} ${$I}profile${$NI} + + ${$B}-translation${$N} ${$I}translation${$NI}" + + @form -form {getall} + @values -min 1 -max 1 + channel + @form -form {getone} + @values -min 2 -max 2 + channel + optionName + + @form -form {set} + @values -min 3 -max -1 + channel + "optionName value" -type {string any} -multiple 1 -optional 0 + + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + + lappend PUNKARGS [list { + @id -id ::tcl::chan::eof + @cmd -name "Builtin: tcl::chan::eof" -help\ + "Test whether the last input operation on the channel called ${$I}channel${$NI} + failed because the end of the data stream was reached, returning 1 if end-of-file + was reached, and 0 otherwise." + @values -min 1 -max 1 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + #event + #flush + #gets + #isbinary + #names + #pending + lappend PUNKARGS [list { + @id -id ::tcl::chan::pipe + @cmd -name "Builtin: tcl::chan::pipe" -help\ + "Creates a standalone pipe whose read- and write-side channels are returned + as a 2-element list, the first element being the read side and the second + write side. Can be useful e.g. to redirect separately ${$B}stderr${$N} and ${$B}stdout${$N} + from a subprocess. To do this spawn with \"2>@\" or \">@\" redirection + operators onto the write side of a pipe, and then immediately close it + in the parent. This is necessary to get an EOF on the read side once the + child has exited or otherwise closed its output. + Note that the pipe buffering semantics can vary at the operating system + level substantially; it is not safe to assume that a write performed on + the output side of the pipe will appear instantly to the input side. + This is a fundamental difference and Tcl cannot conceal it. The overall + stream semantics ${$I}are${$NI} compatible, so blocking reads and writes + will not see most of the differences, but the details of what exactly gets + written when are not. This is most likely to show up when using pipelines + for testing; care should be taken to ensure that deadlocks do not occur + and that potential short reads are allowed for." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + + } lappend PUNKARGS [list { @id -id ::tcl::chan::tell @@ -501,11 +752,12 @@ tcl::namespace::eval punk::args::tclcore { to set the channel to a particular position. Note that this value is in terms of bytes, not characters like ${[a+ bold]}chan read${[a+ normal]}. The value returned is -1 for channels that do not support seeking." - @values + @values -min 1 -max 1 channel -help \ "" } "@doc -name Manpage: -url [manpage_tcl chan]" ] + lappend PUNKARGS [list { @id -id ::tcl::chan::truncate @cmd -name "Builtin: tcl::chan::truncate" -help\ @@ -513,52 +765,305 @@ tcl::namespace::eval punk::args::tclcore { length (or to the current byte offset within the underlying data stream if length is omitted). The channel is flushed before truncation." #todo - auto synopsis? - @form -synopsis\ - "chan truncate channel ?length?" - @values + #@form -synopsis\ + # "chan truncate channel ?length?" + @values -min 1 -max 2 channel -help \ "" length -optional 1 -type integer } "@doc -name Manpage: -url [manpage_tcl chan]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #dict + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tcl::dict::append + @cmd -name "Builtin: tcl::dict::append" -help\ + "This appends the given string (or strings) to the value that the given + key maps to in the dictionary value contained in the given variable, + writing the resulting dictionary value back to that variable. Non-existant + keys are treated as if they map to an empty string. The updated dictionary + value is returned." + @values -min 2 -max -1 + dictionaryVariable -type string -help \ + "" + key + string -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::create + @cmd -name "Builtin: tcl::dict::create" -help\ + "Return a new dictionary that contains each of the key/value mappings listed + as arguments (keys and values alternating, with each key being followed by + its associated value)" + @values -min 2 -max -1 + "key value" -type {string string} -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::exists + @cmd -name "Builtin: tcl::dict::exists" -help\ + "This returns a boolean value indicating whether the given key (or path of + keys through a set of nested dictionaries) exists in the given dictionary + value. This returns a true value exactly when ${$B}dict get${$N} on that path will + succeed." + @values -min 2 -max -1 + dictionaryValue -type dict + key -type string -multiple 1 -optional 0 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::replace + @cmd -name "Builtin: tcl::dict::replace" -help\ + "Return a new dictionary that is a copy of an old one passed in as first + argument except with some values different or some extra key/value pairs + added. It is legal for this command to be called with no key/value pairs, + but illegal for this command to be called with a key but no value." + @values -min 1 -max -1 + dictionaryValue -type dict + "key value" -type {string string} -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #file + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tcl::file::channels + @cmd -name "Builtin: tcl::file::channels" -help\ + "If ${$I}pattern${$NI} is not specified, returns a list of names of all + registered copen channels in this interpreter. If ${$I}pattern${$NI} is + specified, only those names matching ${$I}pattern${$NI} are returned. + Matching is determined using the same rules as for string match." + @opts -prefix 0 + @values -min 0 -max -1 + pattern -optional 1 -type string -default * + } "@doc -name Manpage: -url [manpage_tcl file]" ] - #TODO - autocreate argdef namespace and import B N etc - # ${[B]import[N]} - lappend PUNKARGS [list { - @id -id ::tcl::info::cmdtype - @cmd -name "Builtin: tcl::info::cmdtype" -help\ - "Returns the type of the command named ${$I}commandName${$NI}. - Built-in types are: - ${$B}alias${$N} - ${$I}commandName${$NI} was created by 'interp alias'. In a safe interpreter an - alias is only visible if both the alias and the target are visible. - ${$B}coroutine${$N} - ${$I}commandName${$NI} was created by 'coroutine'. - ${$B}ensemble${$N} - ${$I}commandName${$NI} was created by 'namespace ensemble'. - ${$B}import${$N} - ${$I}commandName${$NI} was created by 'namespace import'. - ${$B}native${$N} - ${$I}commandName${$NI} was created by the 'Tcl_CreateObjCommand' interface - directly without further registration of the type of command. - ${$B}object${$N} - ${$I}commandName${$NI} is the public comand that represents an instance - of oo::object or one of its subclasses. - ${$B}privateObject${$N} - ${$I}commandName${$NI} is the private command, my by default, - that represents an instance of oo::object or one of its subclasses. - ${$B}proc${$N} - ${$I}commandName${$NI} was created by 'proc'. - ${$B}interp${$N} - ${$I}commandName${$NI} was created by 'interp create'. - ${$B}zlibStream${$N} - ${$I}commandName${$NI} was created by 'zlib stream'. - " - @values -min 1 -max 1 - commandName -type string - } "@doc -name Manpage: -url [manpage_tcl info]" ] + lappend PUNKARGS [list { + @id -id ::tcl::file::delete + @cmd -name "Builtin: tcl::file::delete" -help\ + "Removes the file or directory specified by each ${$I}pathname${$NI} argument. + Non-empty directories will be removed only if the ${$B}-force${$N} option is + specified. When operating on symbolic links, the links themselves will be + deleted, not the objects they point to. Trying to delete a non-existent file + is not considered an error. Trying to delete a read-only file will cause the + file to be deleted, even if the ${$B}-force${$N} flag is not specified. If the ${$B}-force${$N} + flag is specified on a directory, Tcl will attempt both to change permissions + and move the current directory \"pwd\" out of the given path if that is + necessary to allow the deletion to proceed. Arguments are processed in the + order specified, halting at the first error, if any. A -- marks the end of + switches; the argument following the -- will be treated as a ${$I}pathname${$NI} + even if it starts with a -." + @opts -prefix 0 + -force -optional 1 -type none + -- -optional 1 -type none + @values -min 0 -max -1 + pathname -optional 1 -type string -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::copy + @cmd -name "Builtin: tcl::file::copy" -help\ + "The first form makes a copy of the file or directory ${$I}source${$NI} under the pathname ${$I}target${$NI}. + If ${$I}target${$NI} is an existing directory then the second form is used. + The second form makes a copy inside ${$I}targetDir${$NI} of each ${$I}source${$NI} file listed. + If a directory is specified as a ${$I}source${$NI}, then the contents of the directory will be + recursiveley copied into ${$I}targetDir${$NI}. Existing files will not be overwritten unless the + ${$B}-force${$N} options is specified (when Tcl will also attempt to adjust permissions on the destination + file or directory if that is necessary to allow the copy to proceed). + When copying within a single filesystem, ${$I}file copy${$NI} will copy soft links (i.e the links themselves + are copied, not the things they point to.) Trying to overwrite a non-empty directory, overwrite a directory + with a file, or overwrite a file with a directory will all result in errors even if ${$B}-force${$N} was + specified. + Arguments are processed in the order specified, halting at the first error, if any. A -- marks the end of + switches; the argument following the -- will be treated as a ${$I}source${$NI} even if it starts with a -." + @form -form {topath inpath} + @opts -form {*} -prefix 0 + -force -optional 1 -type none + -- -optional 1 -type none + + @form -form "topath" + @values -min 2 -max 2 + source -type string -help\ + "file or directory" + target -type string + + @form -form "inpath" + @values -min 2 -max -1 + source -type string -multiple 1 -help\ + "file or directory" + targetDir -optional 1 -type existingdir + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::executable + @cmd -name "Builtin: tcl::file::executable" -help\ + "Returns ${$B}1${$N} if file ${$I}name${$NI} is executable by the current user, ${$B}0${$N} + otherwise. On Windows, which does not have an executable attribute, the command treats + all directories and any files with extensions ${$B}exe${$N}, ${$B}com${$N}, ${$B}cmd${$N} or ${$B}bat${$N} as executable." + @values -min 0 -max 1 + name -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::exists + @cmd -name "Builtin: tcl::file::exists" -help\ + "Returns ${$B}1${$N} if the file ${$I}name${$NI} exists and the current user has search + privileges for the directories leading to it, ${$B}0${$N} otherwise." + @values -min 0 -max 1 + name -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::extension + @cmd -name "Builtin: tcl::file::extension" -help\ + "Returns all of the characters in ${$I}name${$NI} after and including the last dot in the last + element of name. If there is no dot in the last element of ${$I}name${$NI} then returns the + empty string." + @values -min 0 -max 1 + name -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::home + @cmd -name "Builtin: tcl::file::home" -help\ + "If no argument is specified, the command returns the home directory of the current user. + This is generally the value of the ${$B}$HOME${$N} environment variable except that on Windows + platforms backslashes in the path are replaced by forward slashes. An error is raised if + the ${$B}$HOME${$N} environment variable is not set. + if ${$I}username${$NI} is specified, the command returns the home directory configured in the + system for the specified user. Note this may be different that the value of the ${$B}$HOME${$N} + environment variable even when the ${$I}username${$NI} corresponds to the current user. + An error is raised if the ${$I}username${$NI} does not correspond to a user account on the system." + @values -min 0 -max 1 + username -optional 1 -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::isdirectory + @cmd -name "Builtin: tcl::file::isdirectory" -help\ + "Returns ${$B}1${$N} if the file name is a directory, ${$B}0${$N} otherwise." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::isfile + @cmd -name "Builtin: tcl::file::isfile" -help\ + "Returns ${$B}1${$N} if the file name is a regular file, ${$B}0${$N} otherwise." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + #join + #link + #lstat + + lappend PUNKARGS [list { + @id -id ::tcl::file::mkdir + @cmd -name "Builtin: tcl::file::mkdir" -help\ + "Creates each directory specified. + For each pathname ${$I}dir${$NI} specified, this command will create all non-existing parent directories + as well as ${$I}dir${$NI} itself. If an existing directory is specified, then no action is taken and no + error is returned. Trying to overwrite an existing file with a directory will result in an error. + Arguments are processed in the order specified, halting at the first error, if any." + @values -min 0 -max -1 + dir -optional 1 -type string -multiple 1 + #dir -optional 1 -type directory -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::mtime + @cmd -name "Builtin: tcl::file::mtime" -help\ + "Returns a decimal string giving the time at which file ${$I}name${$NI} was last modified. + If ${$I}time${$NI} is specified, it is a modification time to set for the file (equivalent + to Unix ${$B}touch${$N}). The time is measured in the standard POSIX fashion as seconds + from a fixed starting time (often January 1, 1970). If the file does not exist or its + modified time cannot be queried or set then an error is generated. on ${$B}zipfs${$N} + file systems, modification time cannot be explicitly set." + @values -min 1 -max 2 + name -type string + time -type integer -optional 1 + } "@doc -name Manpage: -url [manpage_tcl file]"] + #nativename + #normalize + #owned + #pathtype + lappend PUNKARGS [list { + @id -id ::tcl::file::readable + @cmd -name "Builtin: tcl::file::readable" -help\ + "Returns ${$B}1${$N} if the file ${$I}name${$NI} is readable by the current user, ${$B}0${$N} otherwise." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]"] + #readlink + #rename (2 forms) + #rootname + #separator + #size + #split + #stat + #system + #tail + #tempdir + #tempfile + #tildeexpand + #type + #volumes + lappend PUNKARGS [list { + @id -id ::tcl::file::writable + @cmd -name "Builtin: tcl::file::writable" -help\ + "Returns ${$B}1${$N} if the file ${$I}name${$NI} is writable by the current user, ${$B}0${$N} otherwise." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]"] + + + } + namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::mathfunc::abs + @cmd -name "Builtin: tcl::mathfunc::abs" -help\ + "Returns the absolute value of ${$I}arg${$NI}. ${$I}Arg${$NI} may be either integer + or floating-point, and the result is returned in the same form." + @values -min 1 -max 1 + #review - NaN shouldn't be accepted - specify a range to exclude it. + arg -type number -range {-Inf Inf} + } "@doc -name Manpage: -url [manpage_tcl mathfunc]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::mathfunc::acos + @cmd -name "Builtin: tcl::mathfunc::acos" -help\ + "Returns the arc cosine of ${$I}arg${$NI}, in the range [0,pi] radians. + ${$I}Arg${$NI} should be in the range [-1,1]." + @values -min 1 -max 1 + arg -type number -range {-1 1} + } "@doc -name Manpage: -url [manpage_tcl mathfunc]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #asin + #atan + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::mathfunc::atan2 + @cmd -name "Builtin: tcl::mathfunc::atan2" -help\ + "Returns the arc tangent of ${$I}y/x${$NI}, in the range [-pi,pi] radians. + ${$I}x${$NI} and ${$I}y${$NI} cannot both be 0. If ${$I}x${$NI} is greater + than 0, this is equivalent to \"${$B}atan [expr {y/x}]${$N}\"." + @values -min 2 -max 2 + y -type number + x -type number + } "@doc -name Manpage: -url [manpage_tcl mathfunc]" ] + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::namespace::origin @cmd -name "Builtin: tcl::namespace::origin" -help\ @@ -618,8 +1123,9 @@ tcl::namespace::eval punk::args::tclcore { regarding name resolution. " @opts - -command - -variable + -command -type none + #todo - make mutually exclusive - (separate forms) + -variable -type none @values -min 1 -max 1 name } "@doc -name Manpage: -url [manpage_tcl namespace]" ] @@ -700,16 +1206,97 @@ tcl::namespace::eval punk::args::tclcore { } } - lappend PUNKARGS [list { - @dynamic - @id -id ::array - @cmd -name "Builtin: array" -help\ - "Manipulate array variables" - @values - ${[punk::args::tclcore::argdoc::array_subcommands]} + namespace eval argdoc { + lappend PUNKARGS [list { + @dynamic + @id -id ::append + @cmd -name "Builtin: append" -help\ + "Append to variable + Append al of the ${$I}value${$NI} arguments to the current value of variable + ${$I}varName${$NI}. if ${$I}varName${$NI} does not exist, it is given a value equal + to the concatenation of all the ${$I}value${$NI} arguments. + if ${$I}varName indicates an element that does not exist of an array that has a default value + set, the concatenation of the default value and all the ${$I}value${$NI} arguments will be stored + in the array element. + The result of this command is the new value stored in variable ${$I}varName${$NI}. + This command privides an efficient way to build up long variables incrementally. + For example, \"${$B}append a $b${$N}\" is much more efficient than \"${$B}set a $a$b${$N}\" + if ${$B}$a${$N} is long." + @values -min 1 + varName -optional 0 + value -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl append]" ] + + } - } "@doc -name Manpage: -url [manpage_tcl array]" ] + namespace eval argdoc { + lappend PUNKARGS [list { + @dynamic + @id -id ::array + @cmd -name "Builtin: array" -help\ + "Manipulate array variables" + @leaders + ${[punk::args::tclcore::argdoc::array_subcommands]} + } "@doc -name Manpage: -url [manpage_tcl array]" ] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + lappend PUNKARGS [list { + @id -id ::tcl::array::default + @cmd -name "Builtin: array default" -help\ + "Manages the default value of the array. + Arrays initially have no default value, but this command allows you to set one; + the default value will be returned when reading from an element of the array + ${$I}arrayName${$NI} if the read would otherwise result in an error. + Note that this may cause the ${$B}append${$N}, ${$B}dict${$N}, ${$B}incr${$N} and ${$B}lappend${$N} + commands to change their behaviour in relation to non-existing array elements." + + @form -form exists + @leaders + exists -type literal -help\ + "This returns a boolean value indicating whether a default value has + been set for the array ${$I}arrayName${$NI}. Returns a false value if + ${$I}arrayName${$NI} does not exist. Raises an error if ${$I}arrayName${$NI} + is an existing variable that is not an array." + @values -min 1 -max 1 + arrayName + + @form -form get + @leaders + get -type literal -help\ + "This returns the current default value for the array ${$I}arrayName${$NI}. + Raises an error if ${$I}arrayName${$NI} is an existing variable that is + not an array, or if ${$I}arrayName${$NI} is an array without a default value." + @values -min 1 -max 1 + arrayName + + @form -form set + @leaders + set -type literal -help\ + "This sets the default value for the array ${$I}arrayName${$NI} to ${$I}value${$NI}. + Returns the empty string. Raises an error if ${$I}arrayName${$NI} is an existing + variable that is not an array, or if ${$I}arrayName${$NI} is an illegal name for an + array. If ${$I}arrayName${$NI} does not currently exist, it is created as an empty + array as well as having its default value set." + @values -min 2 -max 2 + arrayName + value + + @form -form unset + @leaders + unset -type literal -help\ + "This removes the default value for the array ${$I}arrayName${$NI} and returns + the empty string. Does nothing if ${$I}arrayName${$NI} does not have a default + value. Raises an error if ${$I}arrayName${$NI} is an existing variable that is + not an array." + @values -min 1 -max 1 + arrayName + + + } "@doc -name Manpage: -url [manpage_tcl array]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -741,6 +1328,67 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl const]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::expr + @cmd -name "Builtin: expr" -help\ + "Evaluate an expression. + Concatenates ${$I}args${$NI}, separated by a space, into an expression, + and evaluates that expression, returning its value. The operators permitted + in an expression include a subset of the operators permitted in C expressions. + For those operators common to both Tcl and C, Tcl applies the same meaning and + precedence as the corresponding C operators. The value of an expression is + often a numeric result, either an integer or a floating-point value, but may + also be a non-numeric value. For example, the expression + ${$B}expr${$N} 8.2 + 6 + evaluates to 14.2. Expressions differ from C expressions in the way that + operands are specified. Expressions also support non-numeric operands, string + comparisons, and some additional operators not found in C. + When the result of expression is an integer, it is in decimal form, and when + the result is a floating-point number, it is in the form produced by the + ${$B}%g${$N} format specifier of ${$B}format${$N}. + At any point in the expression except within double quotes or braces, ${$B}#${$N} + is the beginning of a comment, which lasts to the end of the line or end of + the expression, whichever comes first. + (see manpage for full details)" + @values -min 1 -max -1 + arg -type string -multiple 1 -optional 0 + } "@doc -name Manpage: -url [manpage_tcl expr]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } + namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::foreach + @cmd -name "Builtin: foreach" -help\ + "The ${$B}foreach${$N} command implements a loop where the loop variable(s) + take on values from one or more lists. In the simplest case there is one loop + variable, ${$I}varname${$NI} and one list, ${$I}list${$NI}, that is a list of values + to assign to ${$I}varname${$NI}. The body argument is a Tcl script. For each element + of ${$I}list${$NI} (in order from first to last), ${$B}foreach${$N} assigns the contents + of the element to ${$I}varname${$NI} as if the ${$B}lindex${$N} command had been used + to extract the element, then calls the Tcl interpreter to execute ${$I}body${$NI}. + + In the general case there can be more than one value list, and each value list + can be associated with a list of loop variables. During each iteration of the + loop the variable of each ${$I}varlist${$NI} are assigned consecutive values from + the corresponding ${$I}list${$NI}. Values in each ${$I}list${$NI} are used in order from + first to last, and each value is used exactly once. The total number of loop + iterations is large enough to use up all the values from all the value lists. + If a value list does not contain enough elements for each of its loop variables + in each iteration, empty values are used for the missing elements. + + The ${$B}break${$N} and ${$B}continue${$N} statements may be invoked inside ${$I}body${$NI}, + with the same effect as in the ${$B}for${$N} command. + ${$B}Foreach${$N} returns an empty string." + @values + "varlist list" -type {list list} -multiple 1 -optional 0 + body -type string -optional 0 -help\ + "Tcl script" + } "@doc -name Manpage: -url [manpage_tcl foreach]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } ############################################################################################################################################################ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -751,175 +1399,345 @@ tcl::namespace::eval punk::args::tclcore { ############################################################################################################################################################ + namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::lappend + @cmd -name "builtin: lappend" -help\ + "Append list elements onto a variable. + This command treats the variable given by ${$I}listVar${$NI} as a list and + appends each of the ${$I}value${$NI} arguments to that list as a separate + element, with spaces between elements. If ${$I}listVar${$NI} does not exist, + it is created as a list with elements given by the value arguments. If + ${$I}listVar${$NI} indicates an element that does not exist of an array that + has a default value set, a list that is comprised of the default value with + all the ${$I}value${$NI} arguments appended as elements will be stored in the + array element. ${$I}Lappend${$NI} is similar to ${$I}append${$NI} except that the + values are appended as list elements rather than raw text. This command + provides a relatively efficient way to build up large lists. For example, + ${$B}\"lappend a $b\"${$N} is much more efficient than + ${$B}\"set a [concat $a [list $b]]\"${$N} when ${$B}$a${$N} is long." + @values -min 1 -max -1 + listVar -type string -help\ + "Existing list variable name" + value -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl lappend]"] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::lassign + @cmd -name "builtin: lassign" -help\ + "Assign list elements to variables. + This command treats the value ${$I}list${$NI} as a list and assigns + successive elements from that list to the variables given by the + ${$I}varName${$NI} arguments in order. If there are more variable + names than list elements, the remaining variables are set to the + empty string. If there are more list elements than variables, a + list of unassigned elements is returned." + @values -min 1 -max -1 + list -type list -help\ + "tcl list as a value" + varName -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl lassign]"] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::ledit + @cmd -name "builtin: ledit" -help\ + "Replace elements of a list stored in variable. + " + @values -min 3 -max -1 + listVar -type string -help\ + "Existing list variable name" + first -type indexexpression + last -type indexexpression + value -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl ledit]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lindex + @cmd -name "builtin: lindex" -help\ + "Retrieve an element from a list + " + @values -min 1 -max -1 + list -type list -help\ + "tcl list as a value" + index -type indexexpression -multiple 1 -optional 1 -help\ + "When no index is supplied or a single index is supplied as an empty list, + the value of the entire list is simply returned. + + If a single index is supplied and is a list of indices - this list is used + as a sequence of nested indices. + The command, + lindex $a 1 2 3 + or + lindex $l {1 2 3} + is synonymous with + lindex [lindex [lindex $a 1] 2] 3 + + When presented with a single indes, the lindex command treats list as a Tcl list + and returns the index'th element from it (0 refers to the first element of the + list). In extracting the element, lindex observes the same rules concerning + braces and quotes and backslashes as the Tcl command interpreter; however, + variable substution and command substitution do not occur. If index is negative + or greater than or equal to the number of elements in 'list', then an empty + string is returned. The interpretation of each simple index value is the same + as for the command 'string index', supporting simple index arithmetic and + indices relative to the end of the list. + + If additional index arguments are supplied, then each argument is used in turn + to select an element from the previous indexing operation, allowing the script + to select elements from sublists." + } "@doc -name Manpage: -url [manpage_tcl lindex]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::linsert + @cmd -name "builtin: linsert" -help\ + "Insert elements into a list. + This command produces a new list from ${$I}list${$NI} by insertaing all of the + ${$I}element${$NI} arguments just before the ${$I}index${$NI}'th element of list. + Each ${$I}element${$NI} argument will become a separate element of the new list. + If ${$I}index${$NI} is less than or equal to zero, then the new elements are + inserted at the beginning of the list, and if ${$I}index${$NI} is greater or equal + to the length of ${$I}list${$NI}, it is as if it was ${$B}end${$N}. + As with ${$B}string index${$N}, the ${$I}index${$NI} value supports both simple index + arithmetic and end-relative indexing. + Subject to the restrictions that indices must refer to locations inside the list and + that the ${$I}elements${$NI} will always be inserted in order, insertions are done so + that when ${$I}index${$NI} is start-relative, the first ${$I}element${$NI} will be at that + index in the resulting list, and when ${$I}index${$NI} is end-relative, the last element will + be at that index in the resulting list." + @values -min 2 -max -1 + list -type string -help\ + "tcl list as a value" + index -type indexexpression + element -type any -optional 1 -multiple 1 + @seealso -commands {list list lappend lassign ledit lindex llength lmap lpop lrange lrepeat lreplace lreverse lsearch lseq lset lsort} + } "@doc -name Manpage: -url [manpage_tcl linsert]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::list + @cmd -name "builtin: list" -help\ + "Create a list + + This command returns a list comprised of all the args, or an empty string + if no args are specified. Braces and backslashes get added as necessary, + so that the lindex command may be used on the result to re-extract the + original arguments, and also so that eval may be used to execute the + resulting list, with arg1 comprising the command's name and the other args + comprising its arguments. List produces slightly different results than + concat: concat removes one level of grouping before forming the list, + while list works directly from the original arguments." + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl list]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::llength + @cmd -name "builtin: llength" -help\ + "Count the number of elements in a list. + Treats ${$I}list${$NI} as a list and returns a decimal string giving the + number of elements in it." + @values -min 1 -max 1 + list -type list -help\ + "tcl list as a value" + } "@doc -name Manpage: -url [manpage_tcl llength]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lpop + @cmd -name "builtin: lpop" -help\ + "Get and remove an element in a list. + The ${$B}lpop${$N} command acepts a parameter, ${$I}varName${$NI}, which + it interprets as the name of a variable containing a Tcl list. + It also accepts one or more ${$I}indices${$NI} into the list. If no indices + are presented, it defaults to \"${$B}end${$N}\"." + @values -min 1 -max -1 + listVar -type string -help\ + "Existing list variable name" + index -type indexexpression -default end -optional 1 -multiple 1 -help\ + "When presented with a single index, the lpop command addresses + the index'th element in it, removes it from the list and returns + the element. + If index is negative or greater or equal than the number of + elements in the list in the variable ${$I}listVar${$NI}, an error occurs. + If addition index arguments are supplied, then each argument is used + in turn to address an element within a sublist designated by the + previous indexing operation, allowing the script to remove elements + in sublists, similar to lindex and lset." + } "@doc -name Manpage: -url [manpage_tcl lpop]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lrange + @cmd -name "builtin: lrange" -help\ + "return one or more adjacent elements from a list. + The new list returned consists of elements first through last, inclusive. + The index values first and last are interpreted the same as index values + for the command 'string index', supporting simple index arithmetic and + indices relative to the end of the list. + e.g lrange {a b c} 0 end-1 + " + @values -min 3 -max 3 + list -type list -help\ + "tcl list as a value" + first -type indexexpression -help\ + "index expression for first element" + last -type indexepxression -help\ + "index expression for last element" + } "@doc -name Manpage: -url [manpage_tcl lrange]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lrepeat + @cmd -name "builtin: lrepeat" -help\ + "Build a list by repeating elements + The ${$B}lrepeat${$N} command creates a list of size count * number of + elements by repeating ${$I}count${$NI} times the sequence of elements + ${$I}element${$NI} ... count must be a non-negative integer, ${$I}element${$NI} + can be any Tcl value." + @values -min 1 -max -1 + count -type integer -range {0 ""} + element -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl lrepeat]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lreplace + @cmd -name "builtin: lreplace" -help\ + "Replace elements in a list with new elements. + ${$B}lreplace${$N} returns a new list formed by replacing zero or more + elements of ${$I}list${$NI} with the ${$I}element${$NI} arguments. + ${$I}first${$NI} and ${$I}last${$NI} are index values specifying the first + and last elements of the range to replace. The index values ${$I}first${$NI} and + ${$I}last${$NI} are interpreted the same as index values for the command ${$B}string index${$N}, + supporting simple index arithmetic and indices relative to the end of the list. + 0 refers to the first element of the list, and ${$B}end${$N} refers to the last element + of the list. + If either ${$I}first${$NI} or ${$I}last${$NI} is less than zero, it is considered + to refer to before the first element of the list. This allows ${$B}lreplace${$N} to + prepend elements to ${$I}list${$NI}. If either ${$I}first${$NI} or ${$I}last${$NI} indicates + a position greater than the index of the last element of the list, it is + treated as if it is an index one greater than the last element. This allows + ${$B}lreplace${$N} to append elements to ${$I}list${$NI}. + If ${$I}last${$NI} is less than ${$I}first${$NI}, then any specified elements will + be inserted into the list before the element specified by ${$I}first${$NI}, with + no elements being deleted. + The ${$I}element${$NI} arguments specify zero or more new elements to be added + to the list in place of those that were deleted. Each ${$I}element${$NI} argument + will become a separate element of the list. If no ${$I}element${$NI} arguments + are specified, then the elements between ${$I}first${$NI} and ${$I}last${$NI} are + simply deleted." + @values -min 3 -max -1 + list -type list -help\ + "tcl list as a value" + first -type indexexpression + last -type indexexpression + element -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl lreplace]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lremove + @cmd -name "builtin: lremove" -help\ + "Remove elements from a list by index + lremove returns a new list formed by simultaneously removing zero or + more elements of list at each of the indices given by an arbitrary + number of index arguments. The indices may be in any order and may be + repeated; the element at index will only be removed once. The index + values are interpreted the same as index values for the command + 'string index', supporting simple index arithmetic and indices relative + to the end of the list. 0 refers to the first element of the list, and + end refers to the last element of the list." + @values -min 1 -max -1 + list -type list -help\ + "tcl list as a value" + index -type indexexpression -multiple 1 -optional 1 + + @seealso -commands {list lappend lassign ledit lindex linsert llength lmap lpop lrange lrepeat lreplace lreverse lsearch lseq lset lsort} + } "@doc -name Manpage: -url [manpage_tcl lremove]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lset + @cmd -name "builtin: lset" -help\ + "Change an element in a list. + The ${$B}lset${$N} command accepts a parameter, ${$I}varName${$NI}, which + it interprets as the name of a variable containint a Tcl list. It also + accepts zero or more ${$I}indices${$NI} into the list. The indices may + be presented either consecutively on the command line, or grouped in a + Tcl list and presented as a single argument. Finally, it accepts a new + value for an element of ${$I}varName${$NI}. + If no indices are presented, the command takes the form: + ${$B}lset${$N} ${$I}varName${$NI} ${$I}newValue${$NI} + or + ${$B}lset${$N} ${$I}varName${$NI} {} ${$I}newValue${$NI} + In this case, ${$I}newValue${$NI} replaces the old value of the variable + ${$I}varName${$N}. + + When presented with a single index, the ${$B}lset${$N} command treates the + contents of the ${$I}varName${$NI} variable as a Tcl list. It addresses + the ${$I}index${$NI}'th element in it (0 refers to the first element of the + list). When interpreting the list, ${$B}lset${$N} observes the same rules + concerning braces and quotes and backslashes as the Tcl command interpreter; + however; variable substitution and command substitution do not occur. + The command constructs a new list in which the designated element is replaced + with ${$I}newValue${$NI}. This new list is stored in the variable ${$I}varName${$NI}, + and is also the return value from the ${$B}lset${$N} command. + If ${$I}index${$NI} is negative or greater than the number of elements in + ${$I}$varName${$NI}, then an error occurs. + If ${$I}index${$NI} is equal to the number of elements in ${$I}$varName${$NI}, + then the given element is appended to the list. + The interpretation of each simple ${$I}index${$NI} value is the same as for the + command ${$B}string index${$N}, supporting simple index arithmetic and indices + relative to the end of the list. + If additional ${$I}index${$NI} arguments are supplied, then each argument is used + in turn to address an element within a sublist designated by the previous indexing + operation, allowing the script to alter elements in sublists (or append elements to + sublists). + The command, + ${$B}lset${$N} a 1 2 newValue + or + ${$B}lset${$N} a {1 2} newValue + replaces element 2 of sublist 1 with ${$I}newValue${$NI}. + The integer appearing in each ${$I}index${$NI} argument must be greater than or equal + to zero. The integer appearing in each ${$I}index${$NI} argument must be less than or + equal to the length of the corresponding list. In other wirds, the ${$B}lset${$N} command + can change the size of a list only by appending an element (setting the one after + the current end). If an index is outside the permitted range, an error is reported." + @form -form index + @leaders -min 1 -max -1 + listVar -type string -help\ + "Existing list variable name" + index -type indexexpression -multiple 1 + @values -min 1 -max 1 + newValue -type any - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::lappend - @cmd -name "builtin: lappend" -help\ - "Append list elements onto a variable. - " - @values -min 1 -max -1 - varName -type string -help\ - "variable name" - value -type any -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl lappend]"] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::ledit - @cmd -name "builtin: ledit" -help\ - "Replace elements of a list stored in variable - " - @values -min 3 -max -1 - listVar -type string -help\ - "Existing list variable name" - first -type indexexpression - last -type indexexpression - value -type any -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl ledit]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lindex - @cmd -name "builtin: lindex" -help\ - "Retrieve an element from a list - " - @values -min 1 -max -1 - list -type list -help\ - "tcl list as a value" - index -type indexexpression -multiple 1 -optional 1 -help\ - "When no index is supplied or a single index is supplied as an empty list, - the value of the entire list is simply returned. - - If a single index is supplied and is a list of indices - this list is used - as a sequence of nested indices. - The command, - lindex $a 1 2 3 - or - lindex $l {1 2 3} - is synonymous with - lindex [lindex [lindex $a 1] 2] 3 - - When presented with a single indes, the lindex command treats list as a Tcl list - and returns the index'th element from it (0 refers to the first element of the - list). In extracting the element, lindex observes the same rules concerning - braces and quotes and backslashes as the Tcl command interpreter; however, - variable substution and command substitution do not occur. If index is negative - or greater than or equal to the number of elements in 'list', then an empty - string is returned. The interpretation of each simple index value is the same - as for the command 'string index', supporting simple index arithmetic and - indices relative to the end of the list. - - If additional index arguments are supplied, then each argument is used in turn - to select an element from the previous indexing operation, allowing the script - to select elements from sublists." - } "@doc -name Manpage: -url [manpage_tcl lindex]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::list - @cmd -name "builtin: list" -help\ - "Create a list - - This command returns a list comprised of all the args, or an empty string - if no args are specified. Braces and backslashes get added as necessary, - so that the lindex command may be used on the result to re-extract the - original arguments, and also so that eval may be used to execute the - resulting list, with arg1 comprising the command's name and the other args - comprising its arguments. List produces slightly different results than - concat: concat removes one level of grouping before forming the list, - while list works directly from the original arguments." - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl list]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lpop - @cmd -name "builtin: lpop" -help\ - "Get and remove an element in a list - " - @values -min 1 -max -1 - varName -type string -help\ - "Existing list variable name" - index -type indexexpression -default end -optional 1 -multiple 1 -help\ - "When presented with a single index, the lpop command addresses - the index'th element in it, removes it from the list and returns - the element. - If index is negative or greater or equal than the number of - elements in the list in the variable called varName, an error occurs. - If addition index arguments are supplied, then each argument is used - in turn to address an element within a sublist designated by the - previous indexing operation, allowing the script to remove elements - in sublists, similar to lindex and lset." - } "@doc -name Manpage: -url [manpage_tcl lpop]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lrange - @cmd -name "builtin: lrange" -help\ - "return one or more adjacent elements from a list. - The new list returned consists of elements first through last, inclusive. - The index values first and last are interpreted the same as index values - for the command 'string index', supporting simple index arithmetic and - indices relative to the end of the list. - e.g lrange {a b c} 0 end-1 - " - @values -min 3 -max 3 - list -type list -help\ - "tcl list as a value" - first -help\ - "index expression for first element" - last -help\ - "index expression for last element" - } "@doc -name Manpage: -url [manpage_tcl lrange]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + @form -form indexlist + @leaders -min 2 -max 2 + listVar -type string -help\ + "Existing list variable name" + indexList -type list -optional 1 -multiple 0 + @values -min 1 -max 1 + newValue -type any - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lremove - @cmd -name "builtin: lremove" -help\ - "Remove elements from a list by index - lremove returns a new list formed by simultaneously removing zero or - more elements of list at each of the indices given by an arbitrary - number of index arguments. The indices may be in any order and may be - repeated; the element at index will only be removed once. The index - values are interpreted the same as index values for the command - 'string index', supporting simple index arithmetic and indices relative - to the end of the list. 0 refers to the first element of the list, and - end refers to the last element of the list." - @values -min 1 -max -1 - list -type list -help\ - "tcl list as a value" - index -type indexexpression -multiple 1 -optional 1 - - @seealso -commands {list lappend lassign ledit lindex linsert llength lmap lpop lrange lrepeat lreplace lreverse lsearch lseq lset lsort} - } "@doc -name Manpage: -url [manpage_tcl lremove]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lrange - @cmd -name "builtin: lrange" -help\ - "return one or more adjacent elements from a list. - The new list returned consists of elements first through last, inclusive. - The index values first and last are interpreted the same as index values - for the command 'string index', supporting simple index arithmetic and - indices relative to the end of the list. - e.g lrange {a b c} 0 end-1" - @values -min 3 -max 3 - list -type list -help\ - "tcl list as a value" - first -help\ - "index expression for first element" - last -help\ - "index expression for last element" - } "@doc -name Manpage: -url [manpage_tcl lrange]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } "@doc -name Manpage: -url [manpage_tcl lset]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } ############################################################################################################################################################ @@ -974,8 +1792,27 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + punk::args::define { + @id -id ::split + @cmd -name "builtin: split" -help\ + "Split a string into a proper Tcl list. + Returns a list created by splitting string at each character that is in + the ${$I}splitChars${$NI} argument. Each element of the result list will + consist of the characters from ${$I}string${$NI} that lie between instances + of the characters in ${$I}splitChars${$NI}. Empty list elements will be + generated if string contains adjacent characters in ${$I}splitChars${$NI}, + or if the first or last character of string is in ${$I}splitChars${$NI}. + If ${I}splitChars${$NI} is an empty string then each character of ${$I}string${$NI} + becomes a separate element of the result list. ${$I}splitChars${$NI} defaults + to the standard white-space characters." + @values -min 1 -max 2 + string -type string + splitChars -type string -optional 1 + } "@doc -name Manpage: -url [manpage_tcl split]" + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @@ -1108,7 +1945,7 @@ tcl::namespace::eval punk::args::tclcore { end. The initial string is returned untouched, if first is greater than last, or if first is equal to or greater than the length of the inital string, or last is less than 0." - @values -min 3 -max 3 + @values -min 3 -max 4 string -type string first -type indexexpression last -type indexexpression @@ -1209,7 +2046,7 @@ tcl::namespace::eval punk::args::tclcore { 7-bit ascii range)" boolean\ " Any of the forms allowed - to Tcl_GetBoolean" + for Tcl_GetBoolean" control\ " Any Unicode control char" dict\ @@ -1229,14 +2066,14 @@ tcl::namespace::eval punk::args::tclcore { range." double\ " Any of the forms allowed - to Tcl_GetDoubleFromObj. + for Tcl_GetDoubleFromObj. ${$A_WARN}With optional surrounding${$A_RST} ${$A_WARN}whitespace.${$A_RST}" entier\ " Synonym for integer" false\ " Any of the forms allowed - to Tcl_GetBoolean where the + for Tcl_GetBoolean where the value is false" graph\ " Any Unicode printing char @@ -1279,7 +2116,7 @@ tcl::namespace::eval punk::args::tclcore { (U+feff) (=BOM)" true\ " Any of the forms allowed - to Tcl_GetBoolean where the + for Tcl_GetBoolean where the value is true" upper\ " Any upper case alphabet @@ -1314,8 +2151,8 @@ tcl::namespace::eval punk::args::tclcore { otherwise an empty string will return 1 on any class" -failindex -type variablename -help\ "If -failindex is specified, then if the function returns 0, - the index in the string where the class was no longer valid will be stored - in the variable named." + the index in the string where the class was no longer + valid will be stored in the variable named." @values -min 1 -max 1 string -type string -optional 0 }] "@doc -name Manpage: -url [manpage_tcl string]" @@ -1348,7 +2185,7 @@ tcl::namespace::eval punk::args::tclcore { obsolete {variable vdelete vinfo} }\ -choiceinfo { - add {subhelp "::trace add"} + add {{doctype punkargs} {subhelp ::trace add}} } } "@doc -name Manpage: -url [manpage_tcl trace]" @@ -1363,7 +2200,8 @@ tcl::namespace::eval punk::args::tclcore { "" {command execution variable} }\ -choiceinfo { - command {subhelp "::trace add command"} + command {{doctype punkargs}} + execution {{doctype punkargs}} } } "@doc -name Manpage: -url [manpage_tcl trace]" @@ -1542,10 +2380,13 @@ tcl::namespace::eval punk::args::tclcore { "Create and initialise a namespace variable. " @form -form "setvalues" -synopsis "variable ?name value...? ?name?" - @values -min 2 -max -1 - #todo + @values -min 0 -max -1 + #todo - some sort of striding for values that must occur in groups of length n + #here we have n=2 except for last which can be 1 + #review - how to handle? + #In this case - we don't want name_value to display - as this is only used for documenting a builtin - #For the case where an @argroups is used also for parsing - the help should display the synopsis form + #For the case where an @arggroups is used also for parsing - the help should display the synopsis form #and also the name of the var in which it is placed. # e.g # ?{name value}...? @@ -1570,50 +2411,98 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { if {[catch {zlib::pkgconfig get zlibVersion} ZLIBVERSION]} { set ZLIBVERSION "(unknown)" + } - } - punk::args::define { - @id -id ::zlib - @cmd -name "builtin: ::zlib" -help\ - "zlib - compression and decompression operations - zlib version: ${$::punk::args::tclcore::argdoc::ZLIBVERSION}" - @leaders -min 1 -max 1 - subcommand -type string\ - -choicecolumns 2\ - -choicegroups { - compression {compress decompress deflate gunzip gzip inflate} - channel {push} - streaming {stream} - checksumming {adler32 crc32} - }\ - -choicelabels { - compress "zlib compress string ?level?" - decompress "zlib decompress string ?buffersize?" - deflate "zlib deflate string ?level?" - gunzip "zlib gunzip string ?-headerVar varName?" - gzip "zlib gzip string ?-level level? ?-header dict?" - inflate "zlib inflate string ?bufferSize?" - push "zlib push mode channel ?options ...?" - stream "zlib stream mode ?options?" - adler32 "zlib adler32 string ?initValue?" - crc32 "zlib crc32 string ?initValue?" - }\ - -choiceinfo { - adler32 {} + #zlib is an ensemble-*like* native command + #we can't use 'namespace ensemble configure' to query it + + #define subcommand documentation first + punk::args::define { + @dynamic + @id -id "::zlib adler32" + @cmd -name "builtin: ::zlib adler32" -help\ + "Compute a checksum of binary string ${$I}string${$NI} using the Adler32 + algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. + " + @values -min 1 -max 2 + string -type string + initValue -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + + punk::args::define { + @dynamic + @id -id "::zlib crc32" + @cmd -name "builtin: ::zlib crc32" -help\ + "Compute a checksum of binary string ${$I}string${$NI} using the CRC-32 + algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. + " + @values -min 1 -max 2 + string -type string + initValue -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + + punk::args::define { + @dynamic + @id -id "::zlib compress" + @cmd -name "builtin: ::zlib compress" -help\ + "Returns the zlib-format compressed binary data of the binary string in ${$I}string${$NI}. + If present, ${$I}level${$NI} gives the compression level to use (from 0, which is + uncompressed, to 9, maximally compressed)." + @values -min 1 -max 2 + string -type string + level -type integer -range {0 9} -optional 1 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + + + set CHOICES [list compress decompress deflate gunzip gzip inflate push stream adler32 crc32] + + #manual synopses for subcommands not yet defined + set CHOICELABELS { + compress "zlib compress string ?level?" + decompress "zlib decompress string ?buffersize?" + deflate "zlib deflate string ?level?" + gunzip "zlib gunzip string ?-headerVar varName?" + gzip "zlib gzip string ?-level level? ?-header dict?" + inflate "zlib inflate string ?bufferSize?" + push "zlib push mode channel ?options ...?" + stream "zlib stream mode ?options?" + adler32 "zlib adler32 string ?initValue?" + crc32 "zlib crc32 string ?initValue?" + } + set CHOICEINFO [dict create] + foreach sub $CHOICES { + #default for all + dict set CHOICEINFO $sub {{doctype native}} + } + foreach id [punk::args::get_ids "::zlib *"] { + if {[llength $id] == 2} { + lassign $id _ sub + dict set CHOICEINFO $sub {{doctype native} {doctype punkargs}} + #override manual synopsis entry + dict set CHOICELABELS $sub [punk::ns::synopsis "::zlib $sub"] } + } + + punk::args::define { + @id -id ::zlib + @cmd -name "builtin: ::zlib" -help\ + "zlib - compression and decompression operations + zlib version: ${$ZLIBVERSION}" + @leaders -min 1 -max 1 + subcommand -type string\ + -choicecolumns 2\ + -choicegroups { + compression {compress decompress deflate gunzip gzip inflate} + channel {push} + streaming {stream} + checksumming {adler32 crc32} + }\ + -choicelabels {${$CHOICELABELS}}\ + -choiceinfo {${$CHOICEINFO}} - } "@doc -name Manpage: -url [manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" - punk::args::define { - @id -id "::zlib adler32" - @cmd -name "builtin: ::zlib adler32" -help\ - "Compute a checksum of binary string ${$I}string${$NI} using the Adler32 - algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. - " - @values -min 1 -max 2 - string -type string - initValue -type string -optional 1 - } "@doc -name Manpage: -url [manpage_tcl zlib]" + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- diff --git a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm index 40c5a99e..b563078b 100644 --- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm @@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates { namespace export * namespace eval class { variable PUNKARGS - #set argd [punk::args::get_dict { - # @id -id "::punk::cap::handlers::templates::class::api folders" - # -startdir -default "" - # @values -max 0 - #} $args] - lappend PUNKARGS [list { - @id -id "::punk::cap::handlers::templates::class::api folders" - -startdir -default "" - @values -max 0 - }] + #lappend PUNKARGS [list { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #}] oo::class create api { #return a dict keyed on folder with source pkg as value @@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates { set cname [string map {. _} $capname] set capabilityname $capname } + set class_ns [uplevel 1 [list namespace current]] + + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + @cmd -name "punk::cap::handlers::templates::class::api folders" + -startdir -default "" -help\ + "Defaults to CWD if not supplied" + @values -max 0 + }] method folders {args} { #puts "--folders $args" - set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] + set argd [punk::args::parse $args withid "[self class] folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates { } return $folderdict } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" + @cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\ + "" + @opts -anyopts 1 + #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here + -startdir -default "" + @values -maxvalues -1 + }] method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" - @opts -anyopts 1 - #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here - -startdir -default "" - @values -maxvalues -1 - } $args] + + set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"] + set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { @@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates { my _get_itemdict {*}$arglist } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" + @cmd -name _get_itemdict + @opts -anyopts 0 + -startdir -default "" + -templatefolder_subdir -optional 0 + -command_get_items_from_base -optional 0 + -command_get_item_name -optional 0 + -not -default "" -multiple 1 + @values -maxvalues -1 + globsearches -default * -multiple 1 + }] + #shared algorithm for get_itemdict_* methods #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" - @cmd -name _get_itemdict - @opts -anyopts 0 - -startdir -default "" - -templatefolder_subdir -optional 0 - -command_get_items_from_base -optional 0 - -command_get_item_name -optional 0 - -not -default "" -multiple 1 - @values -maxvalues -1 - globsearches -default * -multiple 1 - } $args] + set argd [punk::args::parse $args withid "[self class] _get_itemdict"] + set opts [dict get $argd opts] set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results #puts stderr "=-=============>globsearches:$globsearches" diff --git a/src/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm index e278d99f..3a5f25b0 100644 --- a/src/modules/punk/config-0.1.tm +++ b/src/modules/punk/config-0.1.tm @@ -44,8 +44,11 @@ tcl::namespace::eval punk::config { @values -min 0 -max 0 }] proc dir {args} { + #set be_quiet [dict exists $received -quiet] if {"-quiet" in $args} { - set be_quiet [dict exists $received -quiet] + set be_quiet 1 + } else { + set be_quiet 0 } set was_noisy 0 @@ -445,6 +448,7 @@ tcl::namespace::eval punk::config { "Get configuration values from a config. Accepts globs eg XDG*" @leaders -min 1 -max 1 + #todo - load more whichconfig choices? whichconfig -type string -choices {config startup-configuration running-configuration} @values -min 0 -max -1 globkey -type string -default * -optional 1 -multiple 1 @@ -526,18 +530,23 @@ tcl::namespace::eval punk::config { error "setting value not implemented" } - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::config::show - @cmd -name punk::config::get -help\ - "Display configuration values from a config. - Accepts globs eg XDG*" - @leaders -min 1 -max 1 - }\ - {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ - "@values -min 0 -max -1"\ - {${[punk::args::resolved_def -types values ::punk::config::get]}}\ - ] + namespace eval argdoc { + set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}} + set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}} + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${$DYN_GET_LEADERS}}\ + "@values -min 0 -max -1"\ + {${$DYN_GET_VALUES}}\ + ] + } proc show {args} { #todo - tables for console set configrecords [punk::config::get {*}$args] @@ -568,7 +577,7 @@ tcl::namespace::eval punk::config { toconfig -help\ "running or startup or file name (not fully implemented)" } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::parse $args withdef $argdef] set fromconfig [dict get $argd values fromconfig] set toconfig [dict get $argd values toconfig] set fromconfig [string map {-config ""} $fromconfig] diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index 87a302a8..923b6f97 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -562,13 +562,13 @@ namespace eval punk::du { proc Get_attributes_from_iteminfo {args} { variable win_reparse_tags_by_int - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::Get_attributes_from_iteminfo -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" - } $args] + }] set opts [dict get $argd opts] set iteminfo [dict get $argd values iteminfo] set opt_debug [dict get $opts -debug] @@ -621,14 +621,14 @@ namespace eval punk::du { proc attributes_twapi {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::attributes_twapi -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" - } $args] + }] set opts [dict get $argd opts] set path [dict get $argd values path] set opt_detail [dict get $opts -detail] diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index 8dc990f6..fedfa7af 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib { } proc range_boundaries {start end chunksizes args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { -offset -default 0 - } $args] + }] lassign [dict values $argd] leaders opts remainingargs } diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index aaeddcce..601aea37 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -1105,7 +1105,7 @@ namespace eval punk::lib { } }] #puts stderr "$argspec" - set argd [punk::args::get_dict $argspec $args] + set argd [punk::args::parse $args withdef $argspec] set opts [dict get $argd opts] set dvar [dict get $argd values dictvar] @@ -1147,7 +1147,7 @@ namespace eval punk::lib { #package require punk ;#we need pipeline pattern matching features package require textblock - set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { @id -id ::punk::lib::showdict @cmd -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject @@ -1178,7 +1178,7 @@ namespace eval punk::lib { "dict or list value" patterns -default "*" -type string -multiple 1 -help\ "key or key glob pattern" - }] $args] + }]] #for punk::lib - we want to reduce pkg dependencies. # - so we won't even use the tcllib debug pkg here @@ -2870,7 +2870,7 @@ namespace eval punk::lib { proc list_as_lines {args} { #*** !doctools #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] - #[para]This simply joines the elements of the list with -joinchar + #[para]This simply joins the elements of the list with -joinchar #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. if {[set eop [lsearch $args --]] == [llength $args]-2} { @@ -2890,12 +2890,11 @@ namespace eval punk::lib { } proc list_as_lines2 {args} { #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? - lassign [tcl::dict::values [punk::args::get_dict { + lassign [tcl::dict::values [punk::args::parse $args withdef { -joinchar -default \n @values -min 1 -max 1 - } $args]] leaders opts values - puts "opts:$opts" - puts "values:$values" + }]] leaders opts values + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] } @@ -2932,10 +2931,10 @@ namespace eval punk::lib { #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc #we don't have to decide what is an opt vs a value #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) - lassign [tcl::dict::values [punk::args::get_dict { + lassign [tcl::dict::values [punk::args::parse $args withdef { @opts -any 1 -block -default {} - } $args]] leaderdict opts valuedict + }]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] } @@ -4198,10 +4197,10 @@ tcl::namespace::eval punk::lib::system { #get info about punk nestindex key ie type: list,dict,undetermined # pdict devel proc nestindex_info {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { -parent -default "" nestindex - } $args] + }] set opt_parent [dict get $argd opts -parent] if {$opt_parent eq ""} { set parent_type undetermined diff --git a/src/modules/punk/lib-buildversion.txt b/src/modules/punk/lib-buildversion.txt index 781c895b..32568297 100644 --- a/src/modules/punk/lib-buildversion.txt +++ b/src/modules/punk/lib-buildversion.txt @@ -1,3 +1,3 @@ -0.1.1 +0.1.2 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm index 54fc4208..42bb6021 100644 --- a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm @@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc { cd $original_wd } proc validate {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::mix::commandset::doc::validate - -- -type none -optional 1 -help "end of options marker --" + -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 - } $args] + }] set opt_individual [tcl::dict::get $argd opts -individual] set patterns [tcl::dict::get $argd values patterns] - + #todo - run and validate punk::docgen output set projectdir [punk::repo::find_project] if {$projectdir eq ""} { diff --git a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm index 731897c7..f15ec2b7 100644 --- a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm @@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout { return [join $layouts \n] } + punk::args::define { + @id -id ::punk::mix::commandset::layout::collection::_default + @cmd -name ::punk::mix::commandset::layout::collection::_default + -startdir -type string + -not -type string -multiple 1 + globsearches -default * -multiple 1 + } proc _default {args} { - punk::args::get_dict [subst { - @id -id ::punk::mix::commandset::layout::collection::_default - @cmd -name ::punk::mix::commandset::layout::collection::_default - -startdir -type string - -not -type string -multiple 1 - globsearches -default * -multiple 1 - }] $args + punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default + set tdict_low_to_high [as_dict {*}$args] #convert to screen order - with higher priority at the top diff --git a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm index 7f50fa87..5e1d19db 100644 --- a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm @@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap { namespace eval lib { #*** !doctools #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] - #[para] Library API functions for punk::mix::commandset::scriptwrap + #[para] Library API functions for punk::mix::commandset::scriptwrap #[list_begin definitions] - + punk::args::define { + @id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders + #*** !doctools + #[call [fun get_wrapper_folders] [arg args] ] + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo + #[para] Arguments: + # [list_begin arguments] + # [arg_def string args] name-value pairs -scriptpath + # [list_end] + @cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\ + "Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo" + @opts -anyopts 0 + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + @values -minvalues 0 -maxvalues 0 + } proc get_wrapper_folders {args} { - set argd [punk::args::get_dict { - #*** !doctools - #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo - #[para] Arguments: - # [list_begin arguments] - # [arg_def string args] name-value pairs -scriptpath - # [list_end] - @id -id ::punk::mix::commandset::scriptwrap - @cmd -name punk::mix::commandset::get_wrapper_folders - - @opts -anyopts 0 - -scriptpath -default "" -type directory\ - -help "" - #todo -help folder within a punk.templates provided area??? - - @values -minvalues 0 -maxvalues 0 - } $args] + set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders] # -- --- --- --- --- --- --- --- --- set opt_scriptpath [dict get $argd opts -scriptpath] diff --git a/src/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index ac63e613..4d66a6ef 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.0.tm @@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs { # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied + punk::args::define { + @id -id ::punk::nav::fs::dirfiles_dict + @cmd -name punk::nav::fs::dirfiles_dict + @opts -any 0 + -searchbase -default "" + -tailglob -default "\uFFFF" + #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) + -with_sizes -default "\uFFFF" -type string + -with_times -default "\uFFFF" -type string + @values -min 0 -max -1 -type string + } proc dirfiles_dict {args} { - set argspecs { - @id -id ::punk::nav::fs::dirfiles_dict - @opts -any 0 - -searchbase -default "" - -tailglob -default "\uFFFF" - #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string - -with_times -default "\uFFFF" -type string - @values -min 0 -max -1 -type string - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict] lassign [dict values $argd] leaders opts vals set searchspecs [dict values $vals] diff --git a/src/modules/punk/netbox-999999.0a1.0.tm b/src/modules/punk/netbox-999999.0a1.0.tm index 1d88ea74..6f7ce699 100644 --- a/src/modules/punk/netbox-999999.0a1.0.tm +++ b/src/modules/punk/netbox-999999.0a1.0.tm @@ -1424,7 +1424,6 @@ tcl::namespace::eval punk::netbox::ipam { NOTE1: tenant is the tenant_id (why?) NOTE: This always uses next available IPs. To create a specific IP, use api/ipam/ip-addresses endpoint. - The returned json is just an object if one address created, but a list if multiple. :/ @@ -1434,6 +1433,65 @@ tcl::namespace::eval punk::netbox::ipam { ] ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_create api/ipam/prefixes/{id}/available-ips/ -verb post -body required + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-prefixes_list + @cmd -name punk::netbox::ipam::prefixes_available-prefixes_list -help\ + "ipam_prefixes_available-prefixes_list + GET request for endpoint /ipam/prefixes/{id}/available-prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${[punk::netbox::api_context_names]}} + @opts + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this prefix" + }\ + ] + ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_list api/ipam/prefixes/{id}/available-prefixes/ -verb get -body none + + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-prefixes_create + @cmd -name punk::netbox::ipam::prefixes_available-prefixes_create -help\ + "ipam_prefixes_available-prefixes_create + POST request for endpoint /ipam/prefixes/{id}/available-prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${[punk::netbox::api_context_names]}} + @opts + }\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LIST]\ + { + @values -min 1 -max 2 + id -type integer -help\ + "A unique integer value identifying this prefix" + body -type string -default "" -help\ + { + { + "prefix_length": 0 + } + } + }\ + ] + ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_create api/ipam/prefixes/{id}/available-prefixes/ -verb post -body required + punk::args::define {*}[list\ { @dynamic diff --git a/src/modules/punk/netbox/man-999999.0a1.0.tm b/src/modules/punk/netbox/man-999999.0a1.0.tm index db1110e9..93baf0c6 100644 --- a/src/modules/punk/netbox/man-999999.0a1.0.tm +++ b/src/modules/punk/netbox/man-999999.0a1.0.tm @@ -100,23 +100,68 @@ package require rest # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::netbox::man { - namespace export {[a-z]*} variable PUNKARGS - - #review + ? - proc uri_part_decode {uripart} { - set specialMap {"[" "%5B" "]" "%5D" + " "} - set seqRE {%([0-9a-fA-F]{2})} - set replacement {[format "%c" [scan "\1" "%2x"]]} - set modstr [regsub -all $seqRE [string map $specialMap $uripart] $replacement] - return [encoding convertfrom utf-8 [subst -nobackslash -novariable $modstr]] + namespace path ::punk::netbox + #create ensemble further down - after sub ensembles exist + + namespace eval contextcommands { + variable nextid 0 + variable commandinfo [dict create] + namespace export {man#*} + proc _cleanup {id args} { + #called by trace on command deletion (trace target must accept args even though not used) + variable commandinfo + dict unset $commandinfo $id + } + proc info {id} { + variable commandinfo + punk::netbox::api_contexts [dict get $commandinfo $id context] + } } - proc uri_get_querystring_as_keyval_list {uri} { - set parts [uri::split $uri] - set query ?[dict get $parts query] - set raw_plist [rest::parameters $query] ;#not a dict - can have repeated params (important for _FILTER methods) - return [lmap v $raw_plist {uri_part_decode $v}] + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::man::new + @cmd -name punk::netbox::man::new -help\ + "Create a command with the apicontextid 'curried' in. + e.g + set svr1 [man tclread new] + $svr1 status + $svr1 tenancy tenants list" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${[punk::netbox::api_context_names]}} + @opts + }\ + ] + proc new {args} { + set argd [punk::args::parse $args withid ::punk::netbox::man::new] + set apicontextid [dict get $argd leaders apicontextid] + upvar ::punk::netbox::man::contextcommands::nextid nextid + upvar ::punk::netbox::man::contextcommands::commandinfo commandinfo + set objname "::punk::netbox::man::contextcommands::man#[incr nextid]" + dict set commandinfo $nextid context $apicontextid + set map [dict create\ + about [list ::punk::netbox::man::about]\ + status [list ::punk::netbox::status $apicontextid]\ + info [list ::punk::netbox::man::contextcommands::info $nextid]\ + destroy [list ::rename $objname ""]\ + ] + set nslist [punk::ns::nslist_dict ::punk::netbox::man::*] + set info [lindex $nslist 0] + set subensembles [dict get $info ensembles] + foreach se $subensembles { + #e.g ip-addresses, tenancy + dict set map $se [list ::punk::netbox::man $apicontextid $se] + } + namespace ensemble create -command $objname -map $map + trace add command $objname delete [list ::punk::netbox::man::contextcommands::_cleanup $nextid] + return $objname } } @@ -131,11 +176,11 @@ tcl::namespace::eval punk::netbox::man::prefixes { #[list_begin definitions] namespace export {[a-z]*} - namespace ensemble create + namespace ensemble create -parameters {apicontextid} variable PUNKARGS lappend PUNKARGS [::list\ - [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes list"}} ::punk::netbox::ipam::prefixes_list]\ + [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes::list"}} ::punk::netbox::ipam::prefixes_list]\ {-RETURN -default table -choices {table tableobject list}}\ {-MAXRESULTS -type integer -default -1}\ {@values -min 0 -max 0}\ @@ -143,12 +188,12 @@ tcl::namespace::eval punk::netbox::man::prefixes { #caution: must use ::list to avoid loop proc list {args} { - set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes list"] - set token tclread ;#todo + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::list"] set urlnext "" set requests_allowed 1000 ;#review set resultlist [::list] + set token [dict get $argd leaders apicontextid] set opts [dict get $argd opts] set vals [dict get $argd values] set multis [dict get $argd multis] @@ -179,7 +224,7 @@ tcl::namespace::eval punk::netbox::man::prefixes { set to_go [expr {$maxresults - [llength $resultlist]}] while {$urlnext ne "null"} { if {$urlnext ne ""} { - set urlnext_params [punk::netbox::man::uri_get_querystring_as_keyval_list $urlnext] + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go } @@ -240,117 +285,606 @@ tcl::namespace::eval punk::netbox::man::prefixes { #return [showdict $resultd] } + tcl::namespace::eval available-ips { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + lappend PUNKARGS [::list\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override {\ + @id {-id "::punk::netbox::man::prefixes::available-ips::create"}\ + -RETURN {-default table -choices {list linelist showlistofdicts}}\ + @values {-min 2 -max 2}\ + body {-optional 0}\ + }\ + ::punk::netbox::ipam::prefixes_available-ips_create\ + ]\ + ] + proc create {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::create"] + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set valuedict [dict get $argd values] + set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + set resultlist [punk::netbox::ipam::prefixes_available-ips_create $token {*}$nextopts -RETURN list {*}$vals] + + switch -- $outer_return { + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + showlistofdicts { + return [punk::lib::showdict $resultlist {@*/@*.@*}] + } + jsondump { + #todo + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $resultlist] + return [huddle::jsondump $h] + } + default { + return $resultlist + } + } - #lappend PUNKARGS [::list\ - # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ - # {-RETURN -default table -choices {table tableobject list}} - # ] - lappend PUNKARGS [::list\ - [punk::args::resolved_def\ - -antiglobs {apicontextid @leaders -offset}\ - -override {\ - @id {-id "::punk::netbox::man::prefixes available-ips_list"}\ - -limit {-default 254 -help "Maximum number of entries to return"}\ - -RETURN {-default table -choices {table tableobject list linelist}}\ - @values {-min 1 -max 1}\ - }\ - ::punk::netbox::ipam::prefixes_available-ips_list\ - ]\ - ] - proc available-ips_list {args} { - set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes available-ips_list"] - set token tclread ;#todo + } - set resultlist [::list] - set opts [dict get $argd opts] - set valuedict [dict get $argd values] - set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func - set multis [dict get $argd multis] - set outer_return [dict get $opts -RETURN] - set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely - #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong - set nextopts [::list] - dict for {opt val} $opts { - if {$opt ni $multis} { - lappend nextopts $opt $val - } else { - foreach v $val { - lappend nextopts $opt $v + #lappend PUNKARGS [::list\ + # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ + # {-RETURN -default table -choices {table tableobject list}} + # ] + lappend PUNKARGS [::list\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override {\ + @id {-id "::punk::netbox::man::prefixes::available-ips::list"}\ + -limit {-default 254 -help "Maximum number of entries to return"}\ + -RETURN {-default table -choices {table tableobject list linelist}}\ + @values {-min 1 -max 1}\ + }\ + ::punk::netbox::ipam::prefixes_available-ips_list\ + ]\ + ] + + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::list"] + + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set valuedict [dict get $argd values] + set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + #No paging available at endpoint ipam/prefixes/available-ips - but we can still use limit (but offset doesn't seem to work) + #REVIEW - no way to know if *all* available in a prefix were returned - could/should? have been limited by server setting + #Especially in an ipv6 context - we're *very* unlikely to want to try to get all! (even for a /16 ipv4 it's probably not a very sensible query) + #Default netbox server limit seems to be 1000? review + #setting -limit 0 seems to allow this to be overridden - giving results bounded only by size of the prefix? + set resultlist [punk::netbox::ipam::prefixes_available-ips_list $token {*}$nextopts -RETURN list {*}$vals] + + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}] + foreach ip $resultlist { + if {[dict exists $ip vrf id]} { + set vrfinfo "[dict get $ip vrf id]: [dict get $ip vrf name]" + } else { + set vrfinfo "-" + } + set r [::list\ + [dict get $ip address]\ + [dict get $ip family]\ + $vrfinfo\ + ] + $t add_row $r } } + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + jsondump { + #todo + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $result] + return [huddle::jsondump $h] + } + default { + return $resultlist + } + } + #return [showdict $resultd] } - #Now opts is a list with possible repeated options! (for flags that have -multiple true) - #No paging available at endpoint ipam/prefixes/available-ips - but we can still use limit (but offset doesn't seem to work) - #REVIEW - no way to know if *all* available in a prefix were returned - could/should? have been limited by server setting - #Especially in an ipv6 context - we're *very* unlikely to want to try to get all! (even for a /16 ipv4 it's probably not a very sensible query) - #Default netbox server limit seems to be 1000? review - #setting -limit 0 seems to allow this to be overridden - giving results bounded only by size of the prefix? - set resultlist [punk::netbox::ipam::prefixes_available-ips_list $token {*}$nextopts -RETURN list {*}$vals] - if {$outer_return in {table tableobject}} { - package require textblock - set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}] - foreach ip $resultlist { - if {[dict exists $ip vrf id]} { - set vrfinfo "[dict get $ip vrf id]: [dict get $ip vrf name]" + } + + tcl::namespace::eval available-prefixes { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + lappend PUNKARGS [::list\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override {\ + @id {-id "::punk::netbox::man::prefixes::available-prefixes::create"}\ + -RETURN {-default table -choices {list linelist showlistofdicts}}\ + @values {-min 2 -max 2}\ + body {-optional 0}\ + }\ + ::punk::netbox::ipam::prefixes_available-prefixes_create\ + ]\ + ] + proc create {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::create"] + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set valuedict [dict get $argd values] + set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val } else { - set vrfinfo "-" + foreach v $val { + lappend nextopts $opt $v + } } - set r [::list\ - [dict get $ip address]\ - [dict get $ip family]\ - $vrfinfo\ - ] - $t add_row $r - } - } - switch -- $outer_return { - table { - set result [$t print] - $t destroy - return $result } - tableobject { - return $t + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + set resultlist [punk::netbox::ipam::prefixes_available-prefixes_create $token {*}$nextopts -RETURN list {*}$vals] + + switch -- $outer_return { + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + showlistofdicts { + return [punk::lib::showdict $resultlist {@*/@*.@*}] + } + jsondump { + #todo + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $resultlist] + return [huddle::jsondump $h] + } + default { + return $resultlist + } } - linelist { - set ret "" - foreach r $resultlist { - append ret $r \n + + + } + + #lappend PUNKARGS [::list\ + # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ + # {-RETURN -default table -choices {table tableobject list}} + # ] + lappend PUNKARGS [::list\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override {\ + @id {-id "::punk::netbox::man::prefixes::available-prefixes::list"}\ + -limit {-default 254 -help "Maximum number of entries to return"}\ + -RETURN {-default table -choices {table tableobject list linelist}}\ + @values {-min 1 -max 1}\ + }\ + ::punk::netbox::ipam::prefixes_available-prefixes_list\ + ]\ + ] + + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::list"] + + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set valuedict [dict get $argd values] + set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } } - return $ret } - jsondump { - #todo - package require huddle::json - #pretty-print via huddle (inefficient review) - set h [huddle::json::json2huddle parse $result] - return [huddle::jsondump $h] + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + set resultlist [punk::netbox::ipam::prefixes_available-prefixes_list $token {*}$nextopts -RETURN list {*}$vals] + + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}] + foreach pfx $resultlist { + if {[dict exists $pfx vrf id]} { + set vrfinfo "[dict get $pfx vrf id]: [dict get $pfx vrf name]" + } else { + set vrfinfo "-" + } + set r [::list\ + [dict get $pfx prefix]\ + [dict get $pfx family]\ + $vrfinfo\ + ] + $t add_row $r + } } - default { - return $resultlist + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + jsondump { + #todo + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $result] + return [huddle::jsondump $h] + } + default { + return $resultlist + } } + #return [showdict $resultd] } - #return [showdict $resultd] + + } + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::netbox::man ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::netbox::man::tenancy { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + tcl::namespace::eval tenants { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + #we're overriding a resolved_def which was dynamic + # - we need to ensure the new definition is also dynamic + # - todo - override rawdef instead? (convenience functions for override of rawdef is missing in punk::args) + lappend PUNKARGS [::list\ + @dynamic\ + [punk::args::resolved_def\ + -antiglobs {@leaders @values -RETURN}\ + -override {@id {-id "::punk::netbox::man::tenancy::tenants::list"} apicontextid {-choices {${[punk::netbox::api_context_names]}}}}\ + ::punk::netbox::tenancy::tenants_list\ + ]\ + {-RETURN -default table -choices {table tableobject list linelist}}\ + {-MAXRESULTS -type integer -default -1}\ + {@values -min 0 -max 0}\ + ] + + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::tenancy::tenants::list"] + + set urlnext "" + set requests_allowed 1000 ;#Sanity check - consider making an option - review + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set vals [dict get $argd values] + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + set maxresults [dict get $opts -MAXRESULTS] + set opts [dict remove $opts -MAXRESULTS] + set initial_pagelimit [dict get $opts -limit] + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + if {$maxresults == -1} { + set maxresults $initial_pagelimit + } + if {$maxresults < $initial_pagelimit} { + punk::netbox::man::system::dupkeylist_setfirst nextopts -limit $maxresults + } + set to_go [expr {$maxresults - [llength $resultlist]}] + while {$urlnext ne "null"} { + if {$urlnext ne ""} { + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] + if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { + punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go + } + punk::netbox::man::system::optionlistvar_sync_from_urlparams nextopts $urlnext_params + } + puts "-->next:$urlnext nextopts:$nextopts vals:$vals" + set resultd [punk::netbox::tenancy::tenants_list $token {*}$nextopts -RETURN dict {*}$vals] + set urlnext [dict get $resultd next] + set batch [dict get $resultd results] + lappend resultlist {*}$batch + + set to_go [expr {$maxresults - [llength $resultlist]}] + if {$to_go <= 0} {break} + incr requests_allowed -1 + if {$requests_allowed < 1} {break} + } + + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {id name slug description group sites racks devices vms IPs}] + foreach ten $resultlist { + + if {[dict exists $ten group id]} { + set group "[dict get $ten group id]: [dict get $ten group slug]" + } else { + set group [dict get $ten group] ;#probably null + } + set r [::list\ + [dict get $ten id]\ + [dict get $ten name]\ + [dict get $ten slug]\ + [dict get $ten description]\ + $group\ + [dict get $ten site_count]\ + [dict get $ten rack_count]\ + [dict get $ten device_count]\ + [dict get $ten virtualmachine_count]\ + [dict get $ten ipaddress_count]\ + ] + $t add_row $r + } + } + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + default { + return $resultlist + } + } + } + + } + +} +tcl::namespace::eval punk::netbox::man::virtualization { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + tcl::namespace::eval virtual-machines { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + lappend PUNKARGS [::list\ + [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::virtualization::virtual-machines::list"}} ::punk::netbox::virtualization::virtual-machines_list]\ + {-RETURN -default table -choices {table tableobject list linelist}}\ + {-MAXRESULTS -type integer -default -1}\ + {@values -min 0 -max 0}\ + ] + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::virtualization::virtual-machines::list"] + + set urlnext "" + set requests_allowed 1000 ;#Sanity check - consider making an option - review + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set vals [dict get $argd values] + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + set maxresults [dict get $opts -MAXRESULTS] + set opts [dict remove $opts -MAXRESULTS] + set initial_pagelimit [dict get $opts -limit] + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + if {$maxresults == -1} { + set maxresults $initial_pagelimit + } + if {$maxresults < $initial_pagelimit} { + punk::netbox::man::system::dupkeylist_setfirst nextopts -limit $maxresults + } + set to_go [expr {$maxresults - [llength $resultlist]}] + while {$urlnext ne "null"} { + if {$urlnext ne ""} { + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] + if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { + punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go + } + punk::netbox::man::system::optionlistvar_sync_from_urlparams nextopts $urlnext_params + } + puts "-->next:$urlnext nextopts:$nextopts vals:$vals" + set resultd [punk::netbox::virtualization::virtual-machines_list $token {*}$nextopts -RETURN dict {*}$vals] + set urlnext [dict get $resultd next] + set batch [dict get $resultd results] + lappend resultlist {*}$batch + + set to_go [expr {$maxresults - [llength $resultlist]}] + if {$to_go <= 0} {break} + incr requests_allowed -1 + if {$requests_allowed < 1} {break} + } + + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {id name site primary_ip4 tags}] + foreach vm $resultlist { + + if {[dict exists $vm site id]} { + set site "[dict get $vm site id]: [dict get $vm site slug]" + } else { + set site [dict get $vm site] ;#probably null + } + if {[dict exists $vm primary_ip4 id]} { + set ip4 [dict get $vm primary_ip4 address] + } else { + set ip4 "" + } + set taglist [dict get $vm tags] + set tagblock "" + foreach taginfo $taglist { + set slug [dict get $taginfo slug] + set rgb [dict get $taginfo color] + append tagblock "[a+ Rgb#$rgb rgb#$rgb-contrasting]$slug[a] " + } + set r [::list\ + [dict get $vm id]\ + [dict get $vm name]\ + $site\ + $ip4\ + $tagblock\ + ] + $t add_row $r + } + } + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + default { + return $resultlist + } + } + } + + } + +} + tcl::namespace::eval punk::netbox::man::ip-addresses { namespace export {[a-z]*} - namespace ensemble create + namespace ensemble create -parameters {apicontextid} variable PUNKARGS lappend PUNKARGS [::list\ - [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::ip-addresses list"}} ::punk::netbox::ipam::ip-addresses_list]\ + [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::ip-addresses::list"}} ::punk::netbox::ipam::ip-addresses_list]\ {-RETURN -default table -choices {table tableobject list linelist}}\ {-MAXRESULTS -type integer -default -1}\ {@values -min 0 -max 0}\ @@ -358,15 +892,15 @@ tcl::namespace::eval punk::netbox::man::ip-addresses { #caution: must use ::list to avoid loop proc list {args} { - set argd [punk::args::parse $args withid "::punk::netbox::man::ip-addresses list"] - set token tclread ;#todo + set argd [punk::args::parse $args withid "::punk::netbox::man::ip-addresses::list"] set urlnext "" set requests_allowed 1000 ;#Sanity check - consider making an option - review set resultlist [::list] - set opts [dict get $argd opts] - set vals [dict get $argd values] - set multis [dict get $argd multis] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set vals [dict get $argd values] + set multis [dict get $argd multis] set outer_return [dict get $opts -RETURN] set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely set maxresults [dict get $opts -MAXRESULTS] @@ -394,7 +928,7 @@ tcl::namespace::eval punk::netbox::man::ip-addresses { set to_go [expr {$maxresults - [llength $resultlist]}] while {$urlnext ne "null"} { if {$urlnext ne ""} { - set urlnext_params [punk::netbox::man::uri_get_querystring_as_keyval_list $urlnext] + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go } @@ -479,7 +1013,41 @@ tcl::namespace::eval punk::netbox::man::ip-addresses { } +#now all sub-ensembles exist - create the ensemble for punk::netbox::man +# - we use a map to exclude any exported procs within the man namespace that don't accept the apicontextid parameter (e.g about) +tcl::namespace::eval punk::netbox::man { + namespace export {[a-z]*} + + set emap [dict create\ + new [list ::punk::netbox::man::new]\ + status [list ::punk::netbox::status]\ + ] + set nslist [punk::ns::nslist_dict ::punk::netbox::man::*] + set info [lindex $nslist 0] + set subensembles [dict get $info ensembles] + foreach se $subensembles { + #e.g ip-addresses, tenancy + dict set emap $se [list ::punk::netbox::man::$se] + } + namespace ensemble create -parameters apicontextid -map $emap +} + tcl::namespace::eval punk::netbox::man::system { + #review + ? + proc uri_part_decode {uripart} { + set specialMap {"[" "%5B" "]" "%5D" + " "} + set seqRE {%([0-9a-fA-F]{2})} + set replacement {[format "%c" [scan "\1" "%2x"]]} + set modstr [regsub -all $seqRE [string map $specialMap $uripart] $replacement] + return [encoding convertfrom utf-8 [subst -nobackslash -novariable $modstr]] + } + + proc uri_get_querystring_as_keyval_list {uri} { + set parts [uri::split $uri] + set query ?[dict get $parts query] + set raw_plist [rest::parameters $query] ;#not a dict - can have repeated params (important for _FILTER methods) + return [lmap v $raw_plist {uri_part_decode $v}] + } #update/add specific members of optionlistvar params in dashed -option format from urlparams in undashed format #members: offset,limit -> -offset,-limit @@ -584,8 +1152,7 @@ tcl::namespace::eval punk::netbox::man { lappend PUNKARGS [list { @id -id "(package)punk::netbox::man" @package -name "punk::netbox::man" -help\ - "Package - Description" + "Management wrapper over netbox rest API" }] namespace eval argdoc { @@ -675,7 +1242,13 @@ namespace eval ::punk::args::register { lappend ::punk::args::register::NAMESPACES\ ::punk::netbox::man\ ::punk::netbox::man::prefixes\ - ::punk::netbox::man::ip-addresses + ::punk::netbox::man::prefixes::available-ips\ + ::punk::netbox::man::prefixes::available-prefixes\ + ::punk::netbox::man::ip-addresses\ + ::punk::netbox::man::tenancy\ + ::punk::netbox::man::tenancy::tenants\ + ::punk::netbox::man::virtualization\ + ::punk::netbox::man::virtualization::virtual-machines\ } # ----------------------------------------------------------------------------- diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index b6999d15..1669eb2a 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -21,7 +21,7 @@ package require punk::lib package require punk::args tcl::namespace::eval ::punk::ns::evaluator { - #eval-_NS_xxx_NS_etc procs + #eval-_NS_xxx_NS_etc procs } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -33,7 +33,7 @@ tcl::namespace::eval punk::ns { } variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns - namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp + namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype resolve_command synopsis namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc catch { @@ -43,7 +43,7 @@ tcl::namespace::eval punk::ns { #debug level punk.ns.compile 3 } - #leading colon makes it hard (impossible?) to call directly if not within the namespace + #leading colon makes it hard (impossible?) to call directly if not within the namespace proc ns/ {v {ns_or_glob ""} args} { variable ns_current ;#change active ns of repl by setting ns_current @@ -67,7 +67,7 @@ tcl::namespace::eval punk::ns { if {$ns_or_glob eq ""} { set is_absolute 1 set ns_queried $ns_current - set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] set has_globchars [regexp {[*?]} $ns_or_glob] @@ -78,10 +78,10 @@ tcl::namespace::eval punk::ns { } set ns_current $ns_or_glob set ns_queried $ns_current - tailcall ns/ $v "" + tailcall ns/ $v "" } else { set ns_queried $ns_or_glob - set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] } } else { if {!$has_globchars} { @@ -91,10 +91,10 @@ tcl::namespace::eval punk::ns { } set ns_current $nsnext set ns_queried $nsnext - set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] } else { set ns_queried [nsjoin $ns_current $ns_or_glob] - set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] } } } @@ -103,7 +103,7 @@ tcl::namespace::eval punk::ns { if {$ns_current in [info commands $ns_current] } { if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { if {[llength $ensemble_info] > 0} { - #this namespace happens to match ensemble command. + #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" } @@ -158,7 +158,7 @@ tcl::namespace::eval punk::ns { } else { set out [get_nslist -match [nsjoin $nsq *] -types [list all]] } - #set out [nslist [nsjoin $nsq *]] + #set out [nslist [nsjoin $nsq *]] set ns_current $nsq append out "\n$ns_current" return $out @@ -252,8 +252,15 @@ tcl::namespace::eval punk::ns { } else { set nsfq $ns } - set ns_script [nseval_ifexists_getscript $nsfq] - uplevel 1 [list {*}$ns_script $script] + if {[lsearch [nsparts $nsfq] :*] >=0} { + #weird_ns + set ns_script [nseval_ifexists_getscript $nsfq] + return [uplevel 1 [list {*}$ns_script $script]] + } else { + if {[namespace exists $nsfq]} { + return [namespace eval $nsfq $script] + } + } } proc nseval_ifexists_getscript {location} { set parts [nsparts $location] @@ -323,7 +330,7 @@ tcl::namespace::eval punk::ns { } #Note nsjoin,nsjoinall,nsprefix,nstail are string functions that don't care about namespaces in existence. - #Some functions in punk::ns are + #Some functions in punk::ns are proc nsjoin {prefix name} { if {[string match ::* $name]} { @@ -422,19 +429,19 @@ tcl::namespace::eval punk::ns { #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y - #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them + #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) - #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string + #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' - #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah - # is this :: punk :etc :blah or :: punk :etc: blah - #clearly leading/trailing colons in namespaces and commands are just a bad idea. + #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah + # is this :: punk :etc :blah or :: punk :etc: blah + #clearly leading/trailing colons in namespaces and commands are just a bad idea. #nsparts will prefer leading colon (ie greedy on ::) #This is important to support leading colon commands such as :/ # ie ::punk:::jjj:::etc -> :: punk :jjj :etc proc nsparts {nspath} { set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] if {[lindex $parts end] eq ""} { @@ -526,7 +533,7 @@ tcl::namespace::eval punk::ns { proc nstree {{location ""}} { if {![string match ::* $location]} { set nscaller [uplevel 1 {::namespace current}] - set location [nsjoin $nscaller $location] + set location [nsjoin $nscaller $location] } list_as_lines [nstree_list $location] } @@ -548,18 +555,18 @@ tcl::namespace::eval punk::ns { set subnslist [dict get $opts -subnslist] set allbelow [dict get $opts -allbelow] ;#whether to return matches longer than the matched glob-path # -- ---- --- --- --- --- - + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $location]] set has_globchars [regexp {[*?]} $ns_absolute] ;#don't use regexes on plain namespaces with no glob chars if {!$has_globchars && !$allbelow && ![llength $subnslist]} { - #short circuit trivial case + #short circuit trivial case return [list $location] } - - set base "" + + set base "" set tailparts [list] - if {$CALLDEPTH == 0} { + if {$CALLDEPTH == 0} { set parts [nsparts $ns_absolute] lset parts 0 :: set idx 0 @@ -577,12 +584,12 @@ tcl::namespace::eval punk::ns { set base $ns_absolute } } else { - set base $location + set base $location set tailparts $subnslist } if {![tcl::namespace::exists $base]} { return [list] - } + } #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] @@ -592,19 +599,19 @@ tcl::namespace::eval punk::ns { #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" - #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx + #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx if {[llength $tailparts]} { set nextglob [lindex $tailparts 0] if {$nextglob eq "**"} { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } elseif {[regexp {[*]{2}$} $nextglob]} { set nslist [list] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] foreach ch $nsmatches { lappend nslist $ch - #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] - lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] - } + #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] + } } else { #lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) set nslist [list] @@ -612,7 +619,7 @@ tcl::namespace::eval punk::ns { if {[llength $tailparts] >1 || $allbelow} { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { #if only one tailpart remaining and not $allbelow - then we already have what we need @@ -626,13 +633,13 @@ tcl::namespace::eval punk::ns { set nslist [list] foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] } } else { set nslist $allchildren } #set nsmatches $allchildren - #set nslist [nstree_list $base -subnslist {} -allbelow 0] + #set nslist [nstree_list $base -subnslist {} -allbelow 0] } set nslist [lsort -unique $nslist] @@ -652,10 +659,10 @@ tcl::namespace::eval punk::ns { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } } @@ -670,14 +677,14 @@ tcl::namespace::eval punk::ns { if {$base ni $nslist} { #puts stderr "> adding $base to $nslist" set nslist [list $base {*}$nslist] - } + } if {$has_globchars} { if {$allbelow} { foreach ns $nslist { if {[globmatchns ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { set nslist_filtered [struct::list::Lfilter $nslist [list globmatchns ${ns_absolute}]] } @@ -687,7 +694,7 @@ tcl::namespace::eval punk::ns { if {[string equal ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { #set nslist_filtered [struct::list::Lfilter $nslist [list string match ${ns_absolute}]] set nslist_filtered [list $ns_absolute] @@ -705,9 +712,54 @@ tcl::namespace::eval punk::ns { if {$ansicodes eq ""} { return $usageinfo_char } elseif {$ansicodes eq "\UFFEF"} { - return " [a+ brightyellow]$usageinfo_char[a]" + return "[a+ brightyellow]$usageinfo_char[a]" + } else { + return "[a+ {*}$ansicodes]$usageinfo_char[a]" + } + } + + punk::args::define { + @id -id ::punk::ns::Cmark + @cmd -name punk::ns::Cmark + @leaders + type -choices {oo ooc ooo punkargs ensemble native} -choicelabels { + oo " symbol \u25c6" + ooc " symbol \u25c7" + ooo " symbol \u25c8" + punkargs " symbol \U1f6c8" + ensemble " symbol \u24ba" + native " symbol \u24c3" + unknown " symbol \u2370" + } + @opts + @values -min 0 -max -1 + ansiname -type string -optional 1 -multiple 1 -help\ + "ansi names as accepted by punk::ansi::a+ + e.g + red bold + (Not raw ansi codes)" + } + proc Cmark {args} { + if {[llength $args] == 0} { + punk::args::parse {} withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + set type [lindex $args 0] + set type [tcl::prefix::match -error "" {oo ooc ooo punkargs ensemble native unknown} $type] + set ansinames [lrange $args 1 end] + switch -- $type { + oo - ooc - ooo - punkargs - ensemble - native - unknown {} + default { + #punk::args::usage ::punk::ns::Cmark + punk::args::parse $args withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + } + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + if {[llength $ansinames]} { + return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]" } else { - return " [a+ {*}$ansicodes]$usageinfo_char[a]" + return [dict get $marks $type] } } @@ -720,7 +772,7 @@ tcl::namespace::eval punk::ns { -nsdict ""\ ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- set fq_glob [dict get $opts -match] set requested_types [dict get $opts -types] set opt_nsdict [dict get $opts -nsdict] @@ -749,7 +801,7 @@ tcl::namespace::eval punk::ns { } foreach t $types { switch -- $t { - oo - all - + oo - all - children - commands - exported - imported - aliases - procs - ensembles - ooclasses - ooobjects - ooprivateobjects - ooprivateclasses - native - coroutines - interps - zlibstreams {} default { error "Unrecognised namespace member type: $t known types: $known_types oo all" @@ -783,19 +835,19 @@ tcl::namespace::eval punk::ns { set usageinfo [list] if {$opt_nsdict eq ""} { - set nsmatches [get_ns_dicts $fq_glob -allbelow 0] + set nsmatches [get_ns_dicts $fq_glob -allbelow 0] set itemcount 0 set matches_with_results [list] foreach nsinfo $nsmatches { - set itemcount [dict get $nsinfo itemcount] + set itemcount [dict get $nsinfo itemcount] if {$itemcount > 0} { lappend matches_with_results $nsinfo - } + } } if {[llength $matches_with_results] == 1} { set contents [lindex $matches_with_results 0] } elseif {[llength $matches_with_results] > 1} { - puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" + puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" set contents [lindex $matches_with_results 0] } else { return "- no results -" @@ -806,7 +858,7 @@ tcl::namespace::eval punk::ns { return "- no results -" } } - set ns [dict get $contents location] + set ns [dict get $contents location] package require overtype if {"children" in $types} { @@ -871,19 +923,19 @@ tcl::namespace::eval punk::ns { } #elements are commands and possibly renamed aliases which may or may not have been renamed into the current namespace - #a command could be an empty string or something else weird. + #a command could be an empty string or something else weird. #Primarily just to handle empty string command - we will wrap each command as a 2-part element here #(our foreach loop needs to ignore missing commands - but not empty string) set elements [lmap v $commands {list c $v}] set seencmds [list] - set masked [list] ;# + set masked [list] ;# #jmn #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { - #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo + #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo #we can detect masking by proc/ensemble/oo - but not by a binary extension loaded after the rename: REVIEW if {$a in $cmdsets} { #we have an alias that is also a known other command-type @@ -896,15 +948,15 @@ tcl::namespace::eval punk::ns { } } set elements [lsort -index 1 $elements] - - + + set numelements [llength $elements] if {$numelements} { set split1 [expr {int(ceil($numelements/4.0))}] set elements1 [lrange $elements 0 $split1-1] set remaining3 [lrange $elements $split1 end] - set numremaining3 [llength $remaining3] + set numremaining3 [llength $remaining3] set split2 [expr {int(ceil($numremaining3/3.0))}] set elements2 [lrange $remaining3 0 $split2-1] set remaining2 [lrange $remaining3 $split2 end] @@ -1019,12 +1071,12 @@ tcl::namespace::eval punk::ns { } } if {$cmd in $usageinfo} { - set u [Usageinfo_mark brightgreen] + set u " [Cmark punkargs brightgreen]" } else { set u "" } set cmd$i "${prefix} $c$cmd_display$u" - #set c$i $c + #set c$i $c set c$i "" lappend seencmds $cmd } @@ -1033,7 +1085,7 @@ tcl::namespace::eval punk::ns { #lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] lappend displaylist $a1[overtype::left $col1 $ch1][a]$a1[overtype::left $col2 $ch2][a]$c1[overtype::left $col3 $cmd1][a]$c2[overtype::left $col4 $cmd2][a]$c3[overtype::left $col5 $cmd3][a]$c4$cmd4[a] } - + return [list_as_lines $displaylist] } proc nspath_here_absolute {{nspath "\uFFFF"}} { @@ -1060,12 +1112,13 @@ tcl::namespace::eval punk::ns { return [nsjoin $base $nspath] } + variable has_textblock set has_textblock [expr {![catch {package require textblock}]}] if {$has_textblock} { interp alias "" ::punk::ns::Block_width "" textblock::width - } else { - #maint - equiv of textblock::width + } else { + #maint - equiv of textblock::width proc Block_width {textblock} { if {$textblock eq ""} { return 0 } if {[tcl::string::last \t $textblock] >=0} { @@ -1085,38 +1138,55 @@ tcl::namespace::eval punk::ns { return [punk::char::ansifreestring_width $textblock] } } - proc nslist {{glob "*"} args} { - set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] - if {[dict exists $args -match]} { - #review - presumably this is due to get_nslist taking -match? - error "nslist requires positional argument 'glob' instead of -match option" - } - set defaults [dict create\ - -match $ns_absolute\ - -nspathcommands 0\ - ] - set opts [dict merge $defaults $args] + punk::args::define { + @id -id ::punk::ns::nslist + @cmd -name punk::ns::nslist -help\ + "Return a textual representation of + the child namespaces and commands within + the namespace(s) matched by glob." + @opts + -nspathcommands -type boolean -default 0 + -types + @values -min 0 -max -1 + glob -multiple 1 -optional 1 -default "*" + } + proc nslist {args} { + set argd [punk::args::parse $args withid ::punk::ns::nslist] + lassign [dict values $argd] leaders opts values received solos multis + + #if {[dict exists $args -match]} { + # #review - presumably this is due to get_nslist taking -match? + # error "nslist requires positional argument 'glob' instead of -match option" + #} + #set defaults [dict create\ + # -match $ns_absolute\ + # -nspathcommands 0\ + #] + #set opts [dict merge $defaults $args] # -- --- --- set opt_nspathcommands [dict get $opts -nspathcommands] # -- --- --- - - - set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + set globlist [dict get $values glob] set with_results [list] - foreach nsdict $ns_matches { - if {[dict get $nsdict itemcount]>0} { - lappend with_results $nsdict + foreach glob $globlist { + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] + set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + foreach nsdict $ns_matches { + if {[dict get $nsdict itemcount]>0} { + lappend with_results $nsdict + } } } - #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' + #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' set count_with_results [llength $with_results] set output "" + variable has_textblock foreach nsdict $with_results { - dict set opts -nsdict $nsdict - set block [get_nslist {*}$opts] + set loc [dict get $nsdict location] + set block [get_nslist -nsdict $nsdict -match ${loc}::* {*}$opts] #if {[string first \n $block] < 0} { # #single line # set width [Block_width [list $block]] @@ -1125,7 +1195,7 @@ tcl::namespace::eval punk::ns { #} set width [Block_width $block] - #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location + #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location if {$count_with_results > 1 || [regexp {[*?]} [nsprefix $ns_absolute]]} { append output \n [dict get $nsdict location] } @@ -1139,17 +1209,24 @@ tcl::namespace::eval punk::ns { } else { append path_text \n " also resolving cmds in namespace paths:" set nspathdict [dict get $nsdict namespacepath] - dict for {k v} $nspathdict { - set cmds [dict get $v commands] - append path_text \n " path: $k" - append path_text \n " cmds: $cmds" + if {!$has_textblock} { + dict for {k v} $nspathdict { + set cmds [dict get $v commands] + append path_text \n " path: $k" + append path_text \n " cmds: $cmds" + } + } else { + dict for {k v} $nspathdict { + set t [textblock::list_as_table -title $k -columns 6 [lsort [dict get $v commands]]] + append path_text \n $t + } } } append output $path_text set path_text_width [Block_width $path_text] - append output \n [string repeat - [expr {max($width,$path_text_width)}]] + append output \n [string repeat - [expr {max($width,$path_text_width)}]] } elseif {$count_with_results > 1 && $width > 0 } { - append output \n [string repeat - $width] + append output \n [string repeat - $width] } } return $output @@ -1160,7 +1237,7 @@ tcl::namespace::eval punk::ns { return [get_ns_dicts $ns_absolute {*}$args] } - #info cmdtype available in 8.7+ + #info cmdtype available in 8.7+ #safe interps also seem to have it disabled for some reason #we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc #IMPORTANT: don't detect easy types such as proc/import here - caller needs the 'na' to do the proper fallback @@ -1227,7 +1304,7 @@ tcl::namespace::eval punk::ns { } #we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller #also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! - return na + return na } #non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob #returns a list of dicts even if only one ns matched @@ -1260,17 +1337,18 @@ tcl::namespace::eval punk::ns { set glob [nstail $fq_glob] set matched_namespaces [nstree_list $nsglob -allbelow $allbelow] - set report_namespaces [list] + set report_namespaces [list] #special case trailing ** in last segment if {[regexp {[*]{2}$} $glob]} { - lappend report_namespaces {*}$matched_namespaces + lappend report_namespaces {*}$matched_namespaces foreach ns $matched_namespaces { lappend report_namespaces {*}[nstree_list [nsjoin $ns $glob]] } } else { - set report_namespaces $matched_namespaces + set report_namespaces $matched_namespaces } - punk::args::update_definitions $report_namespaces + #puts stderr "---->get_ns_dicts '$fq_glob $args' update_definitions $report_namespaces" + punk::args::update_definitions $report_namespaces set nsdict_list [list] foreach ch $report_namespaces { @@ -1280,27 +1358,27 @@ tcl::namespace::eval punk::ns { } else { set allchildren [nschildren $ch] ; #sorted, only returns 1 level deeper } - + #nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string. # By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {} #set commands [.= nscommands -raw [nsjoin $ch $glob] |> punk::lib::linelist -block {}] set commands [punk::lib::linelist -block {} [nscommands -raw [nsjoin $ch $glob]]] - #by convention - returning just \n represents a single result of the empty string whereas no results + #by convention - returning just \n represents a single result of the empty string whereas no results #after passing through linelist this becomes {} {} which appears as a list of two empty strings. - #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines + #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines #unless we always return a newline at the tail if there is a result #For this reason nscommands returns a trailing newline - so the last entry should always be empty string - and is a bogus entry - #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. + #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. if {[lindex $commands end] eq ""} { set commands [lrange $commands 0 end-1] } else { puts stderr "get_ns_dicts WARNING nscommands didn't return a trailing newline - unexpected" } - - + + #JMN - set location $ch + set location $ch set locationparts [nsparts $location] set weird_ns 0 if {[lsearch $locationparts :*] >= 0} { @@ -1309,7 +1387,7 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set exportpatterns [nseval_ifexists $location {::namespace export}] set nspathlist [nseval_ifexists $location {::namespace path}] - } else { + } else { set exportpatterns [tcl::namespace::eval $location {::namespace export}] set nspathlist [tcl::namespace::eval $location {::namespace path}] } @@ -1335,7 +1413,7 @@ tcl::namespace::eval punk::ns { #! info commands can't glob with a weird ns prefix #! info commands with no arguments returns all commands (from global and any other ns in namespace path) #lappend matched {*}[nseval_ifexists $location [list ::info commands [nsjoin ${location} $p]]] - lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { + lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { set allcommands [info commands] set matches [list] foreach c $allcommands { @@ -1360,9 +1438,9 @@ tcl::namespace::eval punk::ns { set allexported [lsort -unique $allexported] #NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace) if {$weird_ns} { - set allprocs [nseval_ifexists $location {::info procs}] + set allprocs [nseval_ifexists $location {::info procs}] } else { - set allprocs [tcl::namespace::eval $location {::info procs}] + set allprocs [tcl::namespace::eval $location {::info procs}] } #set allprocs [nseval $location {::info procs}] set childtails [lmap v $allchildren {nstail $v}] @@ -1382,24 +1460,24 @@ tcl::namespace::eval punk::ns { #use aliases glob - because aliases can be present with or without leading :: #NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases if {$weird_ns} { - set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } else { - set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } - #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] foreach a $raw_aliases { if {[string match *:: $a]} { #exception for alias such as ::p::2:: so that it doesn't show up as empty string #lappend aliases :: #JMN - 2023 - better to display an empty string somehow - lappend aliases "" + lappend aliases "" } else { lappend aliases [nstail $a] } } - #NOTE for 'info ...' 'namespace origin|(etc)..' + #NOTE for 'info ...' 'namespace origin|(etc)..' # - use the pattern [namespace eval $location [list $cmd]] #This allows examination of cmds with "bad" names such as empty string or prefixed with single colon. #while these should be rare - we want to handle such edge cases when browsing namespaces. @@ -1433,7 +1511,7 @@ tcl::namespace::eval punk::ns { } if {$weird_origin} { if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { @@ -1444,7 +1522,7 @@ tcl::namespace::eval punk::ns { } } else { if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { @@ -1454,7 +1532,7 @@ tcl::namespace::eval punk::ns { } } - } + } default { if {$ctype eq "import"} { if {$weird_ns} { @@ -1462,7 +1540,7 @@ tcl::namespace::eval punk::ns { } else { set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] } - #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source + #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source #ie we don't need to follow a chain of 'imported' results. set origin_location [nsprefix $cmdorigin] set origin_cmd [nstail $cmdorigin] @@ -1491,7 +1569,7 @@ tcl::namespace::eval punk::ns { lappend allensembles $cmd } i-alias - alias { - #review + #review lappend allaliases $cmd } i-object - object { @@ -1520,7 +1598,7 @@ tcl::namespace::eval punk::ns { lappend allzlibstreams $cmd } default { - #there may be other registered types + #there may be other registered types #(extensible with Tcl_RegisterCommandTypeName) lappend allothers $cmd } @@ -1535,7 +1613,7 @@ tcl::namespace::eval punk::ns { #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. set nsorigin [namespace origin ${location}::] } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] + set nsorigin [nseval $location "::namespace origin $cmd"] } else { set nsorigin [namespace origin [nsjoin $location $cmd]] } @@ -1585,12 +1663,12 @@ tcl::namespace::eval punk::ns { set imported $allimported set undetermined $allundetermined } - - #itemcount will overcount if we are including commands as well as procs/exported etc - + + #itemcount will overcount if we are including commands as well as procs/exported etc - set itemcount 0 incr itemcount [llength $childtailmatches] incr itemcount [llength $commands] - + #incr itemcount [llength $procs] #incr itemcount [llength $exported] @@ -1606,6 +1684,7 @@ tcl::namespace::eval punk::ns { set has_punkargs [expr {[info commands ::punk::args::id_exists] ne ""}] set has_tepam [expr {[info exists ::tepam::ProcedureList]}] if {$has_punkargs || $has_tepam} { + set ns_updated [dict create] foreach c $commands { if {$c in $imported} { set fq [namespace origin [nsjoin $location $c]] @@ -1613,7 +1692,7 @@ tcl::namespace::eval punk::ns { #TODO - use which_alias ? set tgt [interp alias "" [nsjoin $location $c]] if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] + set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] } set word1 [lindex $tgt 0] if {$word1 eq "punk::mix::base::_cli"} { @@ -1623,7 +1702,11 @@ tcl::namespace::eval punk::ns { } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) - set fq $word1 + if {[string match ::* $word1]} { + set fq $word1 + } else { + set fq ::$word1 + } } } else { set fq [nsjoin $location $c] @@ -1631,7 +1714,12 @@ tcl::namespace::eval punk::ns { if {$has_punkargs} { #set id [string trimleft $fq :] set id $fq - punk::args::update_definitions [list [namespace qualifiers $id]] + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1675,10 +1763,10 @@ tcl::namespace::eval punk::ns { ] lappend nsdict_list $nsdict } - return $nsdict_list + return $nsdict_list } #Must be no ansi when only single arg used. - #review - ansi codes will be very confusing in some scenarios! + #review - ansi codes will be very confusing in some scenarios! #todo - only output color when requested (how?) or via repltelemetry ? interp alias {} nscommands2 {} .= ,'ok'@0.= { #Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x @@ -1688,13 +1776,13 @@ tcl::namespace::eval punk::ns { ::set commandns [::namespace current] ::set commandlist [::list] #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway - #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed + #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed ::set colors [::list none cyan yellow green] ::set ci 0 ;#colourindex ::set do_raw 0 ::if {[::set posn [::lsearch $searchlist -raw]] >= 0} { ::set searchlist [::lreplace $searchlist $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } ::if {![::llength $searchlist]} { ::lappend searchlist * @@ -1714,7 +1802,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1731,7 +1819,7 @@ tcl::namespace::eval punk::ns { ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } if 0 { @@ -1771,19 +1859,19 @@ tcl::namespace::eval punk::ns { ::list ok [::list result $commandlist] #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. - } |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} = 0} { ::set args [::lreplace $args $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } if {![llength $args]} { lappend args * @@ -1801,7 +1889,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1817,7 +1905,7 @@ tcl::namespace::eval punk::ns { set weird_ns 0 if {[string match *:::* $base]} { set weird_ns 1 - } + } #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created if {$weird_ns} { ::if {![nsexists $base]} { @@ -1838,7 +1926,7 @@ tcl::namespace::eval punk::ns { }} $base $what ]] } else { ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] } @@ -1903,7 +1991,7 @@ tcl::namespace::eval punk::ns { info commands ${input} } } - } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + } errM]} { + puts stderr "$errM" + set origin $querycommand + set resolved $querycommand + } + } else { + #fully qualified command specified but doesn't exist + set origin $querycommand + set resolved $querycommand + } + } else { + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand + } else { + #set thispath [uplevel 1 [list ::nsthis $querycommand]] + set thispath [uplevel 1 [list ::punk::ns::nspath_here_absolute $querycommand]] + set targetns [nsprefix $thispath] + set name [nstail $thispath] + set targetparts [nsparts $targetns] + if {[lsearch $targetparts :*] >=0} { + #weird ns + set valid_ns [nsexists $targetns] + } else { + set valid_ns [namespace exists $targetns] + } + if {$valid_ns} { + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + }]} { + set thiscmd [nsjoin $targetns $name] + #relative querycommand specified - but Tcl didn't find a match in namespace path + #assume global (todo - look for namespace match in auto_index first ?) + set origin ::$name + set resolved ::$name + } + } else { + #namespace as relative to current doesn't seem to exist + #Tcl would also attempt to resolve as global + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::resolve_command $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand + + } + } + } + #ns::cmdtype only detects alias type on 8.7+? + set initial_cmdtype [punk::ns::cmdtype $origin] + switch -- $initial_cmdtype { + na - alias { + #REVIEW - alias entry doesn't necessarily match command! + #consider using which_alias (wiki) + set tgt [interp alias "" $origin] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft $origin :]] + } + #first word of tgt may be namespace relative or absolute + if {$tgt ne ""} { + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set targetword [lindex $tgt end] + } else { + #todo - alias may have prefilled some leading args - so usage report should reflect that??? + #(possible curried arguments) + #review - curried arguments could be for ensembles! + set targetword $word1 + return [namespace eval :: [list punk::ns::resolve_command $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + } + + + set origin $targetword + #retest cmdtype on modified origin + set cmdtype [punk::ns::cmdtype $origin] + } else { + set cmdtype $initial_cmdtype + } + if {$cmdtype eq "na"} { + #tcl 8.6 + if {[info object isa object $origin]} { + set cmdtype "object" + } + } + } + default { + set cmdtype $initial_cmdtype + } + } + + punk::args::update_definitions [list [namespace qualifiers $origin]] + set id $origin + + + #don't shortcircuit if no args id - need to allow (autodef) even for argumentless query e.g resolve_command dict + if {[punk::args::id_exists $id] && ![llength $queryargs]} { + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + #puts "--->resolve_command '$args' update_definitions [list [namespace qualifiers $origin]]" + if {![punk::args::id_exists $origin]} { + if {[namespace ensemble exists $origin]} { + #review + #todo - check -unknown + #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + #presumably -choiceprefix should be zero in that case?? + + set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] + + #review - we can have a combination of commands from -map as well as those exported from -namespace + # if and only if -subcommands is specified + + set subcommand_dict [dict create] + set commands [list] + set nscommands [list] + if {[llength [dict get $ensembleinfo -subcommands]]} { + #set exportspecs [namespace eval $ns {namespace export}] + #foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + #} + #when using -subcommands, even unexported commands are available + set nscommands [info commands ${ns}::*] + foreach sub [dict get $ensembleinfo -subcommands] { + if {[dict exists $map $sub]} { + #-map takes precence over same name exported from -namespace + dict set subcommand_dict $sub [dict get $map $sub] + } elseif {"${ns}::$sub" in $nscommands} { + dict set subcommand_dict $sub ${ns}::$sub + } else { + #subcommand probably supplied via -unknown handler? + dict set subcommand_dict $sub "" + } + } + } else { + if {[dict size $map]} { + set subcommand_dict $map + } else { + set exportspecs [namespace eval $ns {namespace export}] + foreach pat $exportspecs { + lappend nscommands {*}[info commands ${ns}::$pat] + } + foreach fqc $nscommands { + dict set subcommand_dict [namespace tail $fqc] $fqc + } + } + } + + + set subcommands [lsort [dict keys $subcommand_dict]] + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs + } + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + #must be exact match - not a prefix + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set resolve_next [list {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + puts "+++> resolve_next: $resolve_next" + + set sub_resolution [resolve_command {*}$resolve_next] + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + + #set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match] + + puts stderr "+++> $sub_resolution" + puts stderr "+++> $f" + dict set sub_resolution args_full $f + return $sub_resolution + } + } + + set choiceinfodict [dict create] + set choicelabeldict [dict create] + + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + dict set choiceinfodict $sub [list [list resolved $subwhat]] + + if {$targettail in [dict get $nsinfo usageinfo]} { + dict lappend choiceinfodict $sub {doctype punkargs} + #dict set choicelabeldict $sub [punk::ns::synopsis $subwhat] + } + if {$targettail in [dict get $nsinfo ensembles]} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + if {$targettail in [dict get $nsinfo ooobjects]} { + if {$targettail in [dict get $nsinfo ooclasses]} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$targettail in [dict get $nsinfo native]} { + dict lappend choiceinfodict $sub {doctype native} + } + } + + + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + set argdef [punk::lib::tstr -return string { + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + Ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -ensembleparameter 1 -help {leading ensemble parameter - passed to subcommand}" + } + } + append argdef \n $vline + punk::args::define $argdef + set id $autoid + } + } + #testing where id = $origin or id = (autodef)::$origin + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set specid $id + set specargs $queryargs + if {[llength $queryargs]} { + #JJJ + set spec [punk::args::get_spec $id] + #TODO -form + set form_names [dict get $spec form_names] + + #'subcommands' only allowed in single-form commands - review + set fid [lindex $form_names 0] + + set leadernames [dict get $spec FORMS $fid LEADER_NAMES] + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + #'subcommands' are only present in forms that consist solely of leaders - REVIEW + #(does not have to dispatch on 1st leader - e.g consider ensemble -parameters) + if {[llength $form_names] == 1 && ![llength $optnames] && ![llength $valnames]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + + set leadernames_matched [lrange $leadernames 0 [llength $queryargs]-1] + foreach q $queryargs lname $leadernames_matched { + if {$lname eq ""} { + break + } + set arginfo [dict get $spec FORMS $fid ARG_INFO $lname] + + set allchoices [list] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + set choiceinfo [punk::args::system::Dict_getdef $arginfo -choiceinfo {}] + set is_ensembleparam [punk::args::system::Dict_getdef $arginfo -ensembleparameter 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 {*}$clist + } + if {$is_ensembleparam} { + #review + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + if {![llength $allchoices]} { + #review - only leaders with a defined set of choices are eligible for consideration as a subcommand + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + + + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + break + } + if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { + #a unique prefix is not sufficient for this arg + break + } + + lappend nextqueryargs $resolved_q + lpop queryargs_untested 0 + if {$resolved_q ne $q} { + #we have our first difference - recurse with new query args + set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested] + set sub_resolution [punk::ns::resolve_command {*}$resolvelist] + #return $sub_resolution + + set sub_origin [dict get $sub_resolution origin] + set sub_argsremaining [dict get $sub_resolution args_remaining] + set sub_resolved [dict get $sub_resolution resolved] + set sub_cmdtype [dict get $sub_resolution cmdtype] + set sub_args_full [dict get $sub_resolution args_full] + puts stderr "===> $sub_resolution" + + return [dict create origin $sub_origin args_remaining $sub_argsremaining resolved $sub_resolved cmdtype $sub_cmdtype args_full $resolvelist] + + } + #check if subcommands so far have a custom args def + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set spec [punk::args::get_spec $currentid] + set form_names [dict get $spec form_names] + set fid [lindex $form_names 0] + + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] + + if {[llength $form_names] != 1} { + break + } + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + if {[llength $optnames] || [llength $valnames]} { + break + } + } else { + set is_subcommand_resolved 0 + set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] + set mapped_subcmd "" + foreach inf $cinfo { + if {[lindex $inf 0] eq "resolved"} { + set mapped_subcmd [lindex $inf 1] + set resolve_next [list {*}$mapped_subcmd {*}$queryargs_untested] + puts "---> resolve_next: $resolve_next" + set sub_resolution [punk::ns::resolve_command {*}$resolve_next] + + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + #set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs] + + puts stderr "---> $sub_resolution" + puts stderr "---> $f" + dict set sub_resolution args_full $f + return $sub_resolution + + + #puts stderr "---> $sub_resolution" + #return $sub_resolution + } + } + + #We can get no further with custom defs + #It is possible we have a documented lower level subcommand but missing the intermediate + #e.g if ::trace remove command was specified and is documented - it will be found above + #but if ::trace remove is not documented and the query is "::trace remove com" + #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + #that's probably ok. + break + } + } + } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs + } + } + + if {[string match (autodef)* $origin]} { + set origin [string range $origin 9 end] + } + + + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + punk::args::define { + @id -id ::punk::ns::forms + @cmd -name punk::ns::forms -help\ + "Return names for each form of a command" + @opts + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc forms {args} { + set argd [::punk::args::parse $args withid ::punk::ns::forms] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::forms $id + } + punk::args::define { + @id -id ::punk::ns::synopsis + @cmd -name punk::ns::synopsis -help\ + "Return synopsis for each form of a command + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc synopsis {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set opt_return [dict get $argd opts -return] + set cmdmembers [dict get $argd values cmditem] + + + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set resolved_id [dict get $cmdinfo origin] + set unresolved_args [dict get $cmdinfo args_remaining] + set full_args [dict get $cmdinfo args_full] + + #puts "---punk::args::synopsis resolve_command result: $cmdinfo" + #REVIEW + set n [llength $unresolved_args] + set idparts [lrange $full_args 0 end-$n] + + set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + if {$syn eq ""} { + return + } + + #when we use list operations on $syn - it can get extra braces due to ANSI - use join to bring back to a string without extraneous bracing + switch -- $opt_return { + full - summary { + set resultstr "" + foreach synline [split $syn \n] { + #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n + append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + } + set resultstr [string trimright $resultstr \n] + #set resultstr [join [lreplace $syn 0 0 {*}$idparts] " "] + return $resultstr + } + dict { + return $syn + } + } + } + proc synopsis_raw {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::synopsis -form $form $id + } + #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? # - as this is interactive generally introspection should be ok at the top level # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? @@ -1989,15 +2596,15 @@ tcl::namespace::eval punk::ns { It supports the following: 1) Procedures or builtins for which a punk::args definition has been loaded. - 2) tepam procedures (returns string form only) + 2) tepam procedures (returns string form only) 3) ensemble commands - auto-generated unless documented via punk::args (subcommands will show with an indicator if they are explicitly documented or are themselves ensembles) - 4) tcl::oo objects - auto-gnerated unless documented via punk::args + 4) tcl::oo objects - auto-gnerated unless documented via punk::args 5) dereferencing of aliases to find underlying command (will not work with some renamed aliases) - Note that native commands commands not explicitly documented will + Note that native commands commands not explicitly documented will generally produce no useful info. For example sqlite3 dbcmd objects could theoretically be documented - but as 'info cmdtype' just shows 'native' they can't (?) be identified as belonging to sqlite3 without @@ -2009,7 +2616,8 @@ tcl::namespace::eval punk::ns { } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - + -form -default 0 -help\ + "Ordinal index or name of command form" -- -type none -help\ "End of options marker Use this if the command to view begins with a -" @@ -2026,19 +2634,21 @@ tcl::namespace::eval punk::ns { #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { - dict set opts -scheme info + #dict set opts -scheme info + set scheme_received 0 + } else { + set scheme_received 1; #so we know not to override caller's explicit choice } set querycommand [dict get $values commandpath] set queryargs [dict get $values subcommand] #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented if {[string match ::* $querycommand]} { set targetns [nsprefix $querycommand] set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global + #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global #when arginfo given a fully qualified path - we only want an answer for that exact command set nscommands [info commands ${targetns}::*] if {[lsearch -exact $nscommands $querycommand] >= 0} { @@ -2051,14 +2661,14 @@ tcl::namespace::eval punk::ns { set resolved $querycommand } } else { - #fully qualified command specified but doesn't exist + #fully qualified command specified but doesn't exist set origin $querycommand set resolved $querycommand } } else { #relative comandpath if {[string match (autodef)* $querycommand]} { - #pass through - should be found with id lookup + #pass through - should be found with id lookup set origin $querycommand set resolved $querycommand } else { @@ -2091,6 +2701,9 @@ tcl::namespace::eval punk::ns { ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] if {$nscaller ne "::"} { + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] } @@ -2104,9 +2717,32 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { + #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { - return [uplevel 1 [list punk::args::usage {*}$opts $origin]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } } } } @@ -2116,7 +2752,7 @@ tcl::namespace::eval punk::ns { switch -- $initial_cmdtype { na - alias { #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) + #consider using which_alias (wiki) set tgt [interp alias "" $origin] if {$tgt eq ""} { set tgt [interp alias "" [string trimleft $origin :]] @@ -2133,9 +2769,12 @@ tcl::namespace::eval punk::ns { #(possible curried arguments) #review - curried arguments could be for ensembles! set targetword $word1 - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] #puts "ALIAS THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] } @@ -2167,9 +2806,33 @@ tcl::namespace::eval punk::ns { #REVIEW - this doesn't cater for prefix callable subcommands set argcopy $queryargs if {[llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "====>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists [list $id {*}$queryargs]]} { - return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + } } } #while {[llength $argcopy]} { @@ -2182,21 +2845,46 @@ tcl::namespace::eval punk::ns { #didn't find any exact matches #traverse from other direction taking prefixes into account - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists $id]} { #cycle forward through leading values - set spec [punk::args::get_spec $id] + set specid $id + set specargs $queryargs if {[llength $queryargs]} { - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + #jjj + set spec [punk::args::get_spec $id] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs set queryargs_untested $queryargs foreach q $queryargs { - if {[llength [dict get $spec LEADER_NAMES]]} { - set subitems [dict get $spec LEADER_NAMES] + if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + set subitems [dict get $spec FORMS $fid LEADER_NAMES] if {[llength $subitems]} { set next [lindex $subitems 0] - set arginfo [dict get $spec ARG_INFO $next] + set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - set allchoices [list] + set allchoices [list] set choices [punk::args::system::Dict_getdef $arginfo -choices {}] set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] if {[dict exists $choicegroups ""]} { @@ -2214,18 +2902,45 @@ tcl::namespace::eval punk::ns { lappend nextqueryargs $resolved_q lpop queryargs_untested 0 if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - #set numvals [expr {[llength $queryargs]+1}] + #we have our first difference - recurse with new query args + #set numvals [expr {[llength $queryargs]+1}] #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - return [ punk::ns::arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested] + if {!$scheme_received} { + dict unset opts -scheme + } + return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] } #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list $id {*}$nextqueryargs] + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] if {[punk::args::id_exists $currentid]} { set spec [punk::args::get_spec $currentid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] } else { #We can get no further with custom defs #It is possible we have a documented lower level subcommand but missing the intermediate @@ -2242,8 +2957,34 @@ tcl::namespace::eval punk::ns { } } } else { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs } } @@ -2261,10 +3002,10 @@ tcl::namespace::eval punk::ns { #the call: info object methods -all # seems to do the right thing as far as hiding unexported methods, and showing things like destroy # - which don't seem to be otherwise easily introspectable - set public_methods [info object methods $origin -all] + set public_methods [info object methods $origin -all] #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - + if {[llength $queryargs]} { set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { @@ -2277,13 +3018,13 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} new" -help\ "create object with specified command name. Arguments are passed to the constructor." - @values + @values }] set i 0 foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2294,7 +3035,31 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin new"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin new"] + } } create { set constructorinfo [info class constructor $origin] @@ -2304,7 +3069,7 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} create" -help\ "create object with specified command name. Arguments following objectName are passed to the constructor." - @values -min 1 + @values -min 1 objectName -type string -help\ "possibly namespaced name for object instance command" }] @@ -2312,7 +3077,7 @@ tcl::namespace::eval punk::ns { foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2323,29 +3088,77 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin create"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin create"] + } } destroy { #review - generally no doc # but we may want notes about a specific destructor set argdef [punk::lib::tstr -return string { - @id -id "(audodef)${$origin} destroy" + @id -id "(autodef)${$origin} destroy" @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." @values -min 0 -max 0 }] punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + } } default { - #use info object call to resolve callchain + #use info object call to resolve callchain #we assume the first impl is the topmost in the callchain # and its call signature is therefore the one we are interested in - REVIEW # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? set implementations [::info object call $origin $c1] - #result documented as list of 4 element lists - #set callinfo [lindex $implementations 0] + #result documented as list of 4 element lists + #set callinfo [lindex $implementations 0] set oodef "" foreach impl $implementations { lassign $impl generaltype mname location methodtype @@ -2396,7 +3209,7 @@ tcl::namespace::eval punk::ns { switch -- [llength $a] { 1 { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2422,6 +3235,7 @@ tcl::namespace::eval punk::ns { } } set choicelabeldict [dict create] + set choiceinfodict [dict create] foreach cmd $public_methods { switch -- $cmd { new - create - destroy { @@ -2437,13 +3251,16 @@ tcl::namespace::eval punk::ns { if {$location eq "object"} { #set id "[string trimleft $origin :] $cmd" ;# " " set id "$origin $cmd" + dict set choiceinfodict $cmd {{doctype ooo}} } else { #set id "[string trimleft $location :] $cmd" ;# " " set id "$location $cmd" + dict set choiceinfodict $cmd {{doctype ooc}} } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { - dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + dict lappend choiceinfodict $cmd {doctype punkargs} } } break @@ -2451,6 +3268,7 @@ tcl::namespace::eval punk::ns { filter { } unknown { + dict set choiceinfodict $cmd {{doctype unknown}} } } } @@ -2458,11 +3276,11 @@ tcl::namespace::eval punk::ns { } } - set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review + set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" set idauto "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$idauto} + @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @leaders -min 1 @@ -2492,6 +3310,7 @@ tcl::namespace::eval punk::ns { #presumably -choiceprefix should be zero in that case?? set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] set prefixes [dict get $ensembleinfo -prefixes] set map [dict get $ensembleinfo -map] set ns [dict get $ensembleinfo -namespace] @@ -2537,54 +3356,142 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] if {[llength $queryargs]} { - set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs } - } - - set namespaces [list] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set ns [::namespace which $subwhat] - if {$ns ni $namespaces} { - lappend namespaces $ns + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + if {!$scheme_received} { + dict unset opts -scheme + } + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #use tailcall so %caller% is reported properly in error msg + tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + } } } + set have_usageinfo [list] set is_ensemble [list] set is_object [list] - foreach ns $namespaces { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin [nsprefix $ns] *]] 0] - lappend have_usageinfo {*}[dict get $nsinfo usageinfo] - lappend is_ensemble {*}[dict get $nsinfo ensembles] - lappend is_object {*}[dict get $nsinfo ooobjects] + set is_class [list] + set is_native [list] + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + if {$targettail in [dict get $nsinfo usageinfo]} { + lappend have_usageinfo $sub + } + if {$targettail in [dict get $nsinfo ensembles]} { + lappend is_ensemble $sub + } + if {$targettail in [dict get $nsinfo ooobjects]} { + lappend is_object $sub + } + if {$targettail in [dict get $nsinfo ooclasses]} { + lappend is_class $sub + } + if {$targettail in [dict get $nsinfo native]} { + lappend is_native $sub + } } + #todo - synopsis? set choicelabeldict [dict create] + + set choiceinfodict [dict create] foreach sub $subcommands { + + if {$sub in $is_ensemble} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + + if {$sub in $is_object} { + if {$sub in $is_class} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$sub in $is_native} { + dict lappend choiceinfodict $sub {doctype native} + } + if {$sub in $have_usageinfo} { - dict set choicelabeldict $sub " [Usageinfo_mark brightgreen]" - } elseif {$sub in $is_ensemble} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" - } elseif {$sub in $is_object} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" + #dict set choiceinfodict $sub [list {doctype punkargs}] + dict lappend choiceinfodict $sub {doctype punkargs} } } - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] set autoid "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} + @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @leaders -min 1 }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } + } append argdef \n $vline punk::args::define $argdef - return [punk::args::usage {*}$opts $autoid] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { + # parsing error e.g Bad number of leading values + #override -scheme in opts with -scheme error + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] + } + #return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2650,14 +3557,41 @@ tcl::namespace::eval punk::ns { } if {[llength $queryargs]} { - #todo - something better - set msg "Undocumented or nonexistant subcommand $origin $queryargs" + #todo - something better ? + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + + if {[punk::args::id_exists $origin]} { + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } + } + set msg "Undocumented or nonexistant command $origin $queryargs" append msg \n "$origin Type: $cmdtype" } else { if {$cmdtype eq "proc"} { set msg "Undocumented proc $origin" append msg \n "No argument processor detected" - append msg \n "function signature: $resolved $argl" + append msg \n "function signature: $resolved $argl" } else { set msg "Undocumented command $origin. Type: $cmdtype" } @@ -2667,15 +3601,15 @@ tcl::namespace::eval punk::ns { #todo - package up as navns proc corp {path} { - #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp + #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) if {[info exists punk::console::tabwidth]} { set tw $::punk::console::tabwidth } else { - set tw 8 + set tw 8 } - set indent [string repeat " " $tw] ;#match - #set indent [string repeat " " $tw] ;#A more sensible default for code - review + set indent [string repeat " " $tw] ;#match + #set indent [string repeat " " $tw] ;#A more sensible default for code - review if {[info exists ::auto_index($path)]} { set body "\n${indent}#corp# auto_index $::auto_index($path)" @@ -2695,7 +3629,7 @@ tcl::namespace::eval punk::ns { } #puts stderr "corp upns:$upns" - #set name [string trim $name :] + #set name [string trim $name :] #set origin [namespace origin ${upns}::$name] set origin [nseval $targetns [list ::namespace origin $name]] set resolved [nseval $targetns [list ::namespace which $name]] @@ -2703,7 +3637,7 @@ tcl::namespace::eval punk::ns { #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! if {$origin ni [info procs $origin]} { - #It seems an interp alias of "::x"" behaves the same as "x" + #It seems an interp alias of "::x"" behaves the same as "x" #But we can't create both at the same time - and they have to be queried by the exact name. #So we query for alias with and without leading :: set alias_qualified [interp alias {} [string trim $origin :]] @@ -2727,7 +3661,7 @@ tcl::namespace::eval punk::ns { #depending on number of aliases in the chain return [list alias {*}$alias] } - } + } if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { append body \n "${indent}#corp# namespace origin $origin" } @@ -2737,7 +3671,7 @@ tcl::namespace::eval punk::ns { } if {![catch {package require textutil::tabify} errpkg]} { set bodytext [info body $origin] - #punk::lib::indent preserves trailing empty lines - unlike textutil version + #punk::lib::indent preserves trailing empty lines - unlike textutil version set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] append body [punk::lib::indent $bodytext $indent] } else { @@ -2880,17 +3814,17 @@ tcl::namespace::eval punk::ns { set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] if {!$ns_populated} { - #we will catch-run an auto_index entry if any - #auto_index entry may or may not be prefixed with :: + #we will catch-run an auto_index entry if any + #auto_index entry may or may not be prefixed with :: set keys [list] #first look for exact pkg_unqualified and ::pkg_unqualified #leave these at beginning of keys list if {[array exists ::auto_index($pkg_unqualified)]} { - lappend keys $pkg_unqualified - } + lappend keys $pkg_unqualified + } if {[array exists ::auto_index(::$pkg_unqualified)]} { - lappend keys ::$pkg_unqualified - } + lappend keys ::$pkg_unqualified + } #as auto_index is an array - we could get keys in arbitrary order set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]] lappend keys {*}$matches @@ -2902,8 +3836,8 @@ tcl::namespace::eval punk::ns { set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] while {!$ns_populated && $i < [llength $keys]} { #todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base - #e.g if we are loading ::x::y - #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc + #e.g if we are loading ::x::y + #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc set k [lindex $keys $i] set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { @@ -2916,7 +3850,7 @@ tcl::namespace::eval punk::ns { } incr i } - + } } } @@ -2924,7 +3858,7 @@ tcl::namespace::eval punk::ns { if {[llength $cmdargs]} { set binding {} #if {[info level] == 1} { - # #up 1 is global + # #up 1 is global # set get_vars [list info vars] #} else { # set get_vars [list info locals] @@ -2955,7 +3889,7 @@ tcl::namespace::eval punk::ns { } else { #A variable can show in the results for 'info vars' (or nsvars) but still not exist. e.g a 'variable x' declaration in the namespace where the variable has never been set } - } + } return [dict create vars $capturevars arrs $capturearrs] } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) } ] @@ -2963,7 +3897,7 @@ tcl::namespace::eval punk::ns { set arglist [lassign $cmdargs scriptblock] if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} { - #one liner without use of $args + #one liner without use of $args append scriptblock { {*}$args} #tailcall apply [list args [string cat $scriptblock { {*}$args}] $ns] {*}$arglist } @@ -3043,7 +3977,7 @@ tcl::namespace::eval punk::ns { error "nsimport_noclobber error namespace $source_ns not found" } - set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] + set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] set a_commands [info commands $pat] #puts "-->commands:'$a_commands'" set a_tails [lmap v $a_commands {tcl::namespace::tail $v}] @@ -3053,11 +3987,11 @@ tcl::namespace::eval punk::ns { foreach m $matches { #we will be using namespace import one by one on commands. #we must protect glob chars that may exist in the actual command names. - #e.g nsimport_noclobber ::punk::ansi::a? + #e.g nsimport_noclobber ::punk::ansi::a? # will import a+ and a? #but nsimport_noclobber {::punk::ansi::a\?} # must import only a? - set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] + set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] if {$m ni $a_exported_tails} { lappend a_exported_tails $m } @@ -3071,7 +4005,7 @@ tcl::namespace::eval punk::ns { set imported_commands [list] if {[namespace exists $nstemp]} { namespace delete $nstemp - } + } namespace eval $nstemp {} foreach e $a_exported_tails { set imported [apply {{tgtns func srcns pfx tmpns} { @@ -3151,13 +4085,13 @@ tcl::namespace::eval punk::ns { @id -id ::i+ @cmd -name "i+" -help\ "Display command help side by side" - @values - cmds -multiple 1 -help\ + @values + cmd -multiple 1 -help\ "Command names for which to show help info" } interp alias {} i+ {}\ .=args> punk::args::get_by_id ::i+ |argd>\ - .=>2 dict get values cmds |cmds>\ + .=>2 dict get values cmd |cmds>\ .=cmds>2 lmap c {i -return tableobject {*}$c} |objs>\ .=objs>2 lmap t {$t configure -show_vseps 0 -show_edge 1} |>\ .=objs>2 lmap t {$t print} |tables>\ @@ -3179,9 +4113,9 @@ tcl::namespace::eval punk::ns { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return \ No newline at end of file diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index 27243335..2fb9a42b 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -100,8 +100,12 @@ namespace eval punk::repo { subcommand -type string -choicecolumns 8 -choicegroups { "frequently used commands" {${$maincommands}} "" {${$othercmds}} - } + } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} }] + #-choiceinfo { + # add {{doctype punkargs}} + # diff {{doctype punkargs}} + #} return $result } @@ -112,7 +116,7 @@ namespace eval punk::repo { # @id -id ::punk::repo::fossil_proxy # @cmd -name fossil -help "fossil executable # " - # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}} # } ""] lappend PUNKARGS [list { @@ -129,7 +133,7 @@ namespace eval punk::repo { @dynamic @id -id "::punk::repo::fossil_proxy diff" @cmd -name "fossil diff" -help "fossil diff" - @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} + @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} } ""] lappend PUNKARGS [list { #todo - remove this comment - testing dynamic directive @@ -137,7 +141,7 @@ namespace eval punk::repo { @id -id "::punk::repo::fossil_proxy add" @cmd -name "fossil add" -help "fossil add " - @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} } ""] #TODO #lappend PUNKARGS [list { @@ -145,7 +149,7 @@ namespace eval punk::repo { # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @cmd -name "fossil add" -help "fossil add # " - # @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # } ""] lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} diff --git a/src/modules/punk/zip-999999.0a1.0.tm b/src/modules/punk/zip-999999.0a1.0.tm index 1b5fa8d7..cdaedb2b 100644 --- a/src/modules/punk/zip-999999.0a1.0.tm +++ b/src/modules/punk/zip-999999.0a1.0.tm @@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip { expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) | ($hour << 11) | ($min << 5) | ($sec >> 1)} } - + punk::args::define { + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -help\ + "Walk the directory structure starting at base/<-subpath> + and return a list of the files and folders encountered. + Resulting paths are relative to base unless -resultrelative + is supplied. + Folder names will end with a trailing slash. + " + -resultrelative -optional 1 -help\ + "Resulting paths are relative to this value. + Defaults to the value of base. If empty string + is given to -resultrelative the paths returned + are effectively absolute paths." + -emptydirs -default 0 -type boolean -help\ + "Whether to include directory trees in the result which had no + matches for the given fileglobs. + Intermediate dirs are always returned if there is a match with + fileglobs further down even if -emptdirs is 0. + " + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" -help\ + "May contain glob chars for folder elements" + @values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } proc walk {args} { #*** !doctools #[call [fun walk] [arg ?options?] [arg base]] #[para] Walk a directory tree rooted at base #[para] the -excludes list can be a set of glob expressions to match against files and avoid - #[para] e.g + #[para] e.g #[example { # punk::zip::walk -exclude {CVS/* *~.#*} library #}] #todo: -relative 0|1 flag? - set argd [punk::args::get_dict { - @id -id ::punk::zip::walk - @cmd -name punk::zip::walk -help\ - "Walk the directory structure starting at base/<-subpath> - and return a list of the files and folders encountered. - Resulting paths are relative to base unless -resultrelative - is supplied. - Folder names will end with a trailing slash. - " - -resultrelative -optional 1 -help\ - "Resulting paths are relative to this value. - Defaults to the value of base. If empty string - is given to -resultrelative the paths returned - are effectively absolute paths." - -emptydirs -default 0 -type boolean -help\ - "Whether to include directory trees in the result which had no - matches for the given fileglobs. - Intermediate dirs are always returned if there is a match with - fileglobs further down even if -emptdirs is 0. - " - -excludes -default "" -help "list of glob expressions to match against files and exclude" - -subpath -default "" -help\ - "May contain glob chars for folder elements" - @values -min 1 -max -1 - base - fileglobs -default {*} -multiple 1 - } $args] + set argd [punk::args::parse $args withid ::punk::zip::walk] set base [dict get $argd values base] set fileglobs [dict get $argd values fileglobs] set subpath [dict get $argd opts -subpath] @@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip { + punk::args::define { + @id -id ::punk::zip::Addentry + @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + @opts + -comment -default "" -help "An optional comment specific to the added file" + @values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } + # Addentry - was Mkzipfile -- # # FIX ME: should handle the current offset for non-seekable channels @@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip { #[para] You can provide a -comment for the file. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. - set argd [punk::args::get_dict { - @id -id ::punk::zip::Addentry - @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' - return a central directory file record" - @opts - -comment -default "" -help "An optional comment specific to the added file" - @values -min 3 -max 4 - zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" - base -help "base path for entries" - path -type file -help "path of file to add" - zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe - Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::Addentry] set zipchan [dict get $argd values zipchan] set base [dict get $argd values base] set path [dict get $argd values path] @@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip { # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) #### + + punk::args::define { + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" + @opts + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix. + " + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + " + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided. + Note that this will + " + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + + @values -min 1 -max -1 + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." + } + # zip::mkzip -- # # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt - # + # proc mkzip {args} { #todo - doctools - [arg ?globs...?] syntax? @@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip { #[para] If a file already exists, an error will be raised. #[para] Call 'punk::zip::mkzip' with no arguments for usage display. - set argd [punk::args::get_dict { - @id -id ::punk::zip::mkzip - @cmd -name punk::zip::mkzip\ - -help "Create a zip archive in 'filename'" - @opts - -offsettype -default "archive" -choices {archive file}\ - -help "zip offsets stored relative to start of entire file or relative to start of zip-archive - Only relevant if the created file has a script/runtime prefix. - " - -return -default "pretty" -choices {pretty list none}\ - -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none\ - -help "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs - " - -runtime -default ""\ - -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review) - " - -comment -default ""\ - -help "An optional comment for the archive" - -directory -default ""\ - -help "The new zip archive will scan for contents within this folder or current directory if not provided. - Note that this will - " - -base -default ""\ - -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" - -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - - @values -min 1 -max -1 - filename -type file -default ""\ - -help "name of zipfile to create" - globs -default {*} -multiple 1\ - -help "list of glob patterns to match. - Only directories with matching files will be included in the archive." - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::mkzip] set filename [dict get $argd values filename] if {$filename eq ""} { error "mkzip filename cannot be empty string" diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test new file mode 100644 index 00000000..a816c75c --- /dev/null +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test @@ -0,0 +1,128 @@ + +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + test parse_withdef_leaders_min_max {Test anonymous leaders with @leaders -min and -max}\ + -setup $common -body { + set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 3} ] + lappend result [dict get $argd leaders] + lappend result [dict get $argd values] + }\ + -cleanup { + }\ + -result [list\ + {0 a 1 b 2 c} {3 d} + ] + + test parse_withdef_leaders_ordering_defaults {Test ordering of leaders when some have defaults}\ + -setup $common -body { + set argd [punk::args::parse {a b} withdef @leaders x {y -default 1}] + set vals [dict get $argd leaders] + set result $vals + }\ + -cleanup { + }\ + -result [list\ + x a y b + ] + + test parse_withdef_option_ordering_defaults {Test ordering of options when some have defaults}\ + -setup $common -body { + #for consistency with leaders and values dicts - try to maintain definition order for options too + set argd [punk::args::parse {-x a -y b} withdef @opts -x {-y -default 1}] + set vals [dict get $argd opts] + set result $vals + }\ + -cleanup { + }\ + -result [list\ + -x a -y b + ] + + test parse_withdef_option_ordering_defaults2 {Test ordering of options when some have defaults and -any is true}\ + -setup $common -body { + #for consistency with leaders and values dicts - try to maintain definition order for options too + set argd [punk::args::parse {-blah etc -x a -y b -solo -z c} withdef {@opts -any 1} -x {-y -default 1} {-solo -type none} -z] + set vals [dict get $argd opts] + set result $vals + }\ + -cleanup { + }\ + -result [list\ + -x a -y b -solo 1 -z c -blah etc + ] + + test parse_withdef_values_ordering_defaults {Test ordering of values when some have defaults}\ + -setup $common -body { + set argd [punk::args::parse {a b} withdef @values x {y -default 1}] + set vals [dict get $argd values] + set result $vals + }\ + -cleanup { + }\ + -result [list\ + x a y b + ] + + test parse_withdef_leader_min_max {Test unnamed leaders with -min and -max}\ + -setup $common -body { + #should not error - should allocate d to values + set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 4} {@values -min 1 -max 1}] + lappend result [dict get $argd leaders] + lappend result [dict get $argd values] + }\ + -cleanup { + }\ + -result [list\ + {0 a 1 b 2 c} {3 d} + ] + + test parse_withdef_leader_stride {Test stride leaders}\ + -setup $common -body { + #see for example ::tcl::dict::create which has a stride of 2 + set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@leaders} {"key val etc" -multiple 0} {"key val" -multiple 1} {@values -min 0 -max 0}] + lappend result [dict get $argd leaders] + }\ + -cleanup { + }\ + -result [list\ + {{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}} + ] + + test parse_withdef_value_stride {Test stride values}\ + -setup $common -body { + #see for example ::tcl::dict::create which has a stride of 2 + set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@values} {"key val etc" -multiple 0} {"key val" -multiple 1}] + lappend result [dict get $argd values] + }\ + -cleanup { + }\ + -result [list\ + {{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}} + ] + + test parse_withdef_value_stride_error {Test stride values with error due to not enough args for stride}\ + -setup $common -body { + #see for example ::tcl::dict::create which has a stride of 2 + if {[catch {punk::args::parse {k v} withdef {@values} {"key val etc" -multiple 0}} emsg eopts]} { + set expected [dict get $eopts -errorcode] + if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "stridevaluecount"} { + lappend result "RECEIVED_EXPECTED_ERROR" + } else { + lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {stridevaluecount ...} ..." + } + } else { + lappend result "MISSING_REQUIRED_ERROR" + } + }\ + -cleanup { + }\ + -result [list\ + "RECEIVED_EXPECTED_ERROR" + ] +} \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test new file mode 100644 index 00000000..1ae2c5c6 --- /dev/null +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test @@ -0,0 +1,125 @@ +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + test define_tstr_template1 {Test basic tstr substitution finds vars in namespace in which define was called}\ + -setup $common -body { + namespace eval whatever { + set plus +++ + set minus --- + + punk::args::define { + @id -id ::testspace::test1 + @values + param -type string -default "${$plus}XXX${$minus}YYY" + } + } + + set argd [punk::args::parse {} withid ::testspace::test1] + set vals [dict get $argd values] + lappend result [dict get $vals param] + }\ + -cleanup { + namespace delete ::testspace::whatever + }\ + -result [list\ + +++XXX---YYY + ] + + test define_tstr_template2 {Test basic tstr substitution when @dynamic}\ + -setup $common -body { + namespace eval whatever { + set plus +++ + set minus --- + + punk::args::define { + @dynamic + @id -id ::testspace::test2 + @values + param -type string -default "${$plus}XXX${$minus}YYY" + } + } + + set argd [punk::args::parse {} withid ::testspace::test2] + puts ">>>>define_tstr_template2 argd:$argd" + set vals [dict get $argd values] + lappend result [dict get $vals param] + }\ + -cleanup { + namespace delete ::testspace::whatever + }\ + -result [list\ + +++XXX---YYY + ] + + test define_tstr_template3 {Test double tstr substitution when @dynamic}\ + -setup $common -body { + variable test_list + set test_list {A B C} + proc ::testspace::get_list {} { + variable test_list + return $test_list + } + namespace eval whatever { + set plus +++ + set minus --- + set DYN_LIST {${[::testspace::get_list]}} + set DYN_CLOCKSECONDS {${[clock seconds]}} + + punk::args::define { + @dynamic + @id -id ::testspace::test2 + @values + param1 -type string -default "${$plus}XXX${$minus}YYY" + param2 -type list -default "${$DYN_LIST}" + param3 -type string -default "${[clock seconds]}" + param4 -type string -default "${$DYN_CLOCKSECONDS}" + } + } + + set argd [punk::args::parse {} withid ::testspace::test2] + set vals [dict get $argd values] + lappend result [dict get $vals param1] + lappend result [dict get $vals param2] + set c1_at_define [dict get $vals param3] + set c1_at_resolve [dict get $vals param4] + + #update test_list to ensure parse is actually dynamic + set ::testspace::test_list {X Y Z} + #update plus - should not affect output as it is resolved at define time + set ::testspace::whatever::plus "new+" + #unset minus - should not cause error + unset ::testspace::whatever::minus + after 1100 ;#ensure more than 1 sec apart + + + set argd [punk::args::parse {} withid ::testspace::test2] + set vals [dict get $argd values] + lappend result [dict get $vals param1] + lappend result [dict get $vals param2] + set c2_at_define [dict get $vals param3] + set c2_at_resolve [dict get $vals param4] + + if {$c1_at_define == $c2_at_define} { + lappend result "OK_define_time_var_match" + } else { + lappend result "UNEXPECTED_define_time_var_mismatch" + } + if {$c1_at_resolve < $c2_at_resolve} { + lappend result "OK_resolve_time_2_greater" + } else { + lappend result "UNEXPECTED_resolve_time_2_not_greater" + } + + }\ + -cleanup { + namespace delete ::testspace::whatever + }\ + -result [list\ + +++XXX---YYY {A B C} +++XXX---YYY {X Y Z} OK_define_time_var_match OK_resolve_time_2_greater + ] +} \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test new file mode 100644 index 00000000..432e9f6d --- /dev/null +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test @@ -0,0 +1,60 @@ + +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + namespace import ::punk::ansi::a+ ::punk::ansi::a + variable common { + set result "" + } + test synopsis_basic {test basic synopsis of punkargs definition}\ + -setup $common -body { + namespace eval testns { + punk::args::define { + @id -id ::testspace::testns::t1 + @leaders + a1 -optional 0 + @opts + -o1 -type boolean + @values + v1 -optional 1 + } + } + lappend result [punk::ns::synopsis ::testspace::testns::t1] + }\ + -cleanup { + namespace delete ::testspace::testns + }\ + -result [list\ + "::testspace::testns::t1 [a+ italic]a1[a] ?-o1 ? ?[a+ italic]v1[a]?" + ] + + test synopsis_basic_ensemble-like {test basic synopsis of punkargs ensemble-like definition}\ + -setup $common -body { + namespace eval testns { + punk::args::define { + @id -id ::testspace::testns::t1 + @leaders -min 1 + subcmd -default c1 -choices {c1 c2} + @values -min 0 -max 0 + } + punk::args::define { + @id -id "::testspace::testns::t1 c1" + @values -min 0 -max 1 + v1 -type string + } + + } + lappend result [punk::ns::synopsis ::testspace::testns::t1] + lappend result [punk::ns::synopsis ::testspace::testns::t1 c1] + }\ + -cleanup { + namespace delete ::testspace::testns + }\ + -result [list\ + "::testspace::testns::t1 [a+ italic]subcmd[a]"\ + "::testspace::testns::t1 c1 [a+ italic]v1[a]" + ] + + +} diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/args.test#..+args+args.test.fauxlink b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/args.test#..+args+args.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm new file mode 100644 index 00000000..1903a58a --- /dev/null +++ b/src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm @@ -0,0 +1,226 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application test::punk::args 999999.0a1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_test::punk::args 0 999999.0a1.0] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require test::punk::args] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of test::punk::args +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by test::punk::args +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + + +tcl::namespace::eval test::punk::args { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace test::punk::args}] + #[para] Core API functions for test::punk::args + #[list_begin definitions] + + variable PUNKARGS + + variable pkg test::punk::args + variable version + set version 999999.0a1.0 + + package require packageTest + packageTest::makeAPI test::punk::args $version punk::args; #will package provide test::punk::args $version + + package forget punk::args + package require punk::args + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace test::punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval test::punk::args::system { + #*** !doctools + #[subsection {Namespace test::punk::args::system}] + #[para] Internal functions that are not part of the API + + + +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval test::punk::args { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)test::punk::args" + @package -name "test::punk::args" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return test::punk::args + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package test::punk::args + test suite for punk::args + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::test::punk::args::version" + } + proc get_topic_Contributors {} { + set authors {{ Julian Noble}} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::test::punk::args::about" + dict set overrides @cmd -name "test::punk::args::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About test::punk::args + }] \n] + dict set overrides topic -choices [list {*}[test::punk::args::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [test::punk::args::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::test::punk::args::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::test::punk::args::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::test::punk::args +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide test::punk::args [tcl::namespace::eval test::punk::args { + variable pkg test::punk::args + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/test/punk/args-buildversion.txt b/src/modules/test/punk/args-buildversion.txt new file mode 100644 index 00000000..97365480 --- /dev/null +++ b/src/modules/test/punk/args-buildversion.txt @@ -0,0 +1,3 @@ +0.1.5 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index b9dd4f9f..1a20bee2 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -140,16 +140,18 @@ tcl::namespace::eval textblock { # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # "algorithm choice" - - punk::args::define { - @dynamic - @id -id ::textblock::use_hash - @cmd -name "textblock::use_hash" -help\ - "Hashing algorithm to use for framecache lookup. - 'none' may be slightly faster but less compact - when viewing textblock::framecache" - @values -min 0 -max 1 - hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} + namespace eval argdoc { + set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]} + punk::args::define { + @dynamic + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP} + } } proc use_hash {args} { #set argd [punk::args::get_by_id ::textblock::use_hash $args] @@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock { -size -type integer\ -default 15\ -optional 1\ - -range {1 15} + -range {1 ""} -direction -default horizontal\ -choices {horizontal vertical}\ -help\ - "When rainbow is in the colour list, - this also affects the direction of - colour changes" - @values -min 0 -max 2 + "Direction of character increments. + When rainbow is in the colour list, + the colour stripes will be oriented + in this direction. + " + @values -min 0 -max 1 colour -type list -default {} -optional 1 -help\ "List of Ansi colour names - e.g. testblock 10 {white Red} + e.g. testblock -size 10 {white Red} produces a block of character 10x10 with white text on red bacground @@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock { set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + if {$size <= 15} { + set charsubset [lrange $chars 0 $size-1] + } else { + set numsets [expr {int(ceil($size / 15.0))}] + set longset [concat {*}[lrepeat $numsets $chars]] + set charsubset [lrange $longset 0 $size-1] + + set longbows [concat {*}[lrepeat $numsets $rainbow_list]] + set rainbow_list [lrange $longbows 0 $size-1] + } if {"noreset" in $colour} { set RST "" } else { @@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock { append row $c } append row $RST - append block $row\n + append block $row \n } set block [tcl::string::trimright $block \n] return $block } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST + if {$direction eq "vertical"} { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block + } else { + set block "" + for {set r 0} {$r < $size} {incr r} { + append block [::join $charsubset ""] \n + } + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block } - return $block } } interp alias {} testblock {} textblock::testblock @@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock { proc ::textblock::join1 {args} { - lassign [punk::args::get_dict { + lassign [punk::args::parse $args withdef { + @id -id ::textblock::join1 -ansiresets -default 1 -type integer blocks -type string -multiple 1 - } $args] _l leaders _o opts _v values + }] _l leaders _o opts _v values set blocks [tcl::dict::get $values blocks] set idx 0 @@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock { #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner #" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::textblock::join_basic2 -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -ansiresets -type any -default auto blocks -type any -multiple 1 - } $args] + }] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock { #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #they may however still be 'ragged' ie differing line lengths proc ::textblock::join {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - #-ansireplays is always on (if ansi detected) #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets @@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock { } proc ::textblock::join2 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock { } # This calls textblock::pad per cell :/ proc ::textblock::join3 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock { NOTE: more options available - argument definition is incomplete" @opts - -return -choices {table tableobject} + -return -default table -choices {table tableobject} -rows -type list -default "" -help\ "A list of lists. Each toplevel element represents a row. @@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock { -help "restrict to keys matching memberglob." }] #append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args + punk::args::parse $args withdef $spec return } diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index 9809dc62..b73cbac8 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -2044,6 +2044,10 @@ if {[file exists $mapfile]} { } # -- --- --- --- --- --- --- --- --- --- puts "-- runtime_vfs_map --" +set ver [package require punk::args] +puts "punk::args ver: $ver" +set ifneeded [package ifneeded punk::args $ver] +puts "punk::args ifneeded: $ifneeded" punk::lib::pdict runtime_vfs_map puts "---------------------" puts "-- vfs_runtime_map--" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm index 1ede846b..40366143 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application argparsingtest 0.1.0 # Meta platform tcl -# Meta license MIT +# Meta license MIT # @@ Meta End @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_argparsingtest 0 0.1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require argparsingtest] #[keywords module] #[description] @@ -106,7 +106,7 @@ namespace eval argparsingtest { #*** !doctools #[subsection {Namespace argparsingtest}] - #[para] Core API functions for argparsingtest + #[para] Core API functions for argparsingtest #[list_begin definitions] proc test1_ni {args} { @@ -277,8 +277,8 @@ namespace eval argparsingtest { #punk::args is slower than argp - but comparable, and argp doesn't support solo flags proc test1_punkargs {args} { set argd [punk::args::parse $args withdef { - @id -id ::argparsingtest::test1_punkargs - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -298,7 +298,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::test1_punkargs_by_id - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -320,7 +320,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::argparsingtest::test1_punkargs2 - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -334,7 +334,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -3 -default 3 -type integer @values - } + } proc test1_punkargs2 {args} { set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] return [tcl::dict::get $argd opts] @@ -342,9 +342,9 @@ namespace eval argparsingtest { proc test1_punkargs_validate_ansistripped {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs_validate_ansistripped - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string @@ -358,7 +358,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true @values - } $args] + }] return [tcl::dict::get $argd opts] } @@ -387,11 +387,11 @@ namespace eval argparsingtest { package require cmdline #cmdline::getoptions is much faster than typedGetoptions proc test1_cmdline_untyped {args} { - set cmdlineopts_untyped { - {return.arg "string" "return val"} + set cmdlineopts_untyped { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -405,11 +405,11 @@ namespace eval argparsingtest { return [::cmdline::getoptions args $cmdlineopts_untyped $usage] } proc test1_cmdline_typed {args} { - set cmdlineopts_typed { - {return.arg "string" "return val"} + set cmdlineopts_typed { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -465,7 +465,7 @@ namespace eval argparsingtest { #multiline values use first line of each record to determine amount of indent to trim proc test_multiline {args} { set t3 [textblock::frame t3] - set argd [punk::args::get_dict [subst { + set argd [punk::args::parse $args withdef [subst { -template1 -default { ****** * t1 * @@ -476,7 +476,7 @@ namespace eval argparsingtest { * t2 * ******} -template3 -default {$t3} - #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately + #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately -template3b -default { $t3 ----------------- @@ -491,20 +491,20 @@ namespace eval argparsingtest { " -flag -default 0 -type boolean - }] $args] + }]] return $argd } #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] - # return "ok" + # return "ok" #} @@ -524,14 +524,14 @@ namespace eval argparsingtest::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace argparsingtest::lib}] - #[para] Secondary functions that are part of the API + #[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 + # #[para]Description of utility1 + # return 1 #} @@ -549,17 +549,17 @@ namespace eval argparsingtest::lib { namespace eval argparsingtest::system { #*** !doctools #[subsection {Namespace argparsingtest::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide argparsingtest [namespace eval argparsingtest { variable pkg argparsingtest variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm index 7884214c..b2561a20 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm @@ -99,8 +99,11 @@ namespace eval commandstack { } } - proc get_stack {command} { + proc get_stack {{command ""}} { variable all_stacks + if {$command eq ""} { + return $all_stacks + } set command [uplevel 1 [list namespace which $command]] if {[dict exists $all_stacks $command]} { return [dict get $all_stacks $command] @@ -116,6 +119,7 @@ namespace eval commandstack { variable all_stacks if {[dict exists $all_stacks $command]} { set stack [dict get $all_stacks $command] + #stack is a list of dicts, 1st entry is token { } set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] if {$posn > -1} { set record [lindex $stack $posn] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm index 44da4684..540a1696 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm @@ -134,12 +134,12 @@ namespace eval modpod { #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::connect -type -default "" @values -min 1 -max 1 path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] + }] catch { punk::lib::showdict $argd ;#heavy dependencies } @@ -168,7 +168,7 @@ namespace eval modpod { } else { #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) set this_pkg_tm_folder [file dirname $modpodpath] if {$connected(type,$modpodpath) ne "unwrapped"} { #Not directly connected to unwrapped version - but may still be redirected there @@ -225,11 +225,15 @@ namespace eval modpod { if {$connected(startdata,$modpodpath) >= 0} { #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { seek $fh $connected(startdata,$modpodpath) start return [list ok $fh] } else { #error "cannot verify tar header" + #try zipfs + if {[info commands tcl::zipfs::mount] ne ""} { + + } } } lpop connected(to) end @@ -262,11 +266,12 @@ namespace eval modpod { return 1 } proc get {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::modpod::get -from -default "" -help "path to pod" - *values -min 1 -max 1 + @values -min 1 -max 1 filename - } $args] + }] set frompod [dict get $argd opts -from] set filename [dict get $argd values filename] @@ -329,7 +334,7 @@ namespace eval modpod::lib { #zipfile is a pure zip at this point - ie no script/exe header proc make_zip_modpod {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::lib::make_zip_modpod -offsettype -default "archive" -choices {archive file} -help\ "Whether zip offsets are relative to start of file or start of zip-data within the file. @@ -340,7 +345,7 @@ namespace eval modpod::lib { @values -min 2 -max 2 zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] + }] set zipfile [dict get $argd values zipfile] set outfile [dict get $argd values outfile] set opt_offsettype [dict get $argd opts -offsettype] @@ -359,7 +364,7 @@ namespace eval modpod::lib { set moddir [file dirname $modfile] set mod_and_ver [file rootname [file tail $modfile]] lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { + if {[file exists $moddir/#modpod-$mod_and_ver]} { source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm } else { #determine module namespace so we can mount appropriately diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index c7207cc0..fd638812 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore { smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ config ::punk::config\ + s ::punk::ns::synopsis\ ] #*** !doctools diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index f671311f..a7fe1047 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu foreach {pt code} $parts { switch -- [llength $codestack] { 0 { - append emit $base$pt$R + append emit $base $pt $R } 1 { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { - append emit $base$pt$R + append emit $base $pt $R set codestack [list] } else { #append emit [lindex $o_codestack 0]$pt if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } default { if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } @@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append emit $code } } - return $emit$R + return [append emit $R] } else { return $base$text$R } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.6.tm new file mode 100644 index 00000000..c3bf04b8 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.6.tm @@ -0,0 +1,6400 @@ +# -*- 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.6 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.6] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $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_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + #set val_min $v + dict set F $fid VAL_MIN $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #now cycle through ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set 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]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + #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::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + 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 parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + 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(goodarg) [a+ green strike] + set CLR(goodchoice) [a+ reverse] + 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(goodarg) [a+ strike] + 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 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $form_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $form_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + set id [lindex $tailargs 0] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + + 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-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } 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 + + #JJJJ + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$valmax == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $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 <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $valname_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $validx}] + } + #------------------------------------------ + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + 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 + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -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 + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer 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 + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.6 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.7.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.7.tm new file mode 100644 index 00000000..b04f4966 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.7.tm @@ -0,0 +1,6458 @@ +# -*- 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.7 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.7] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache [list $optionspecs]] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + + #set opt_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + #set val_min $v + dict set F $fid VAL_MIN $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #now cycle through ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$deflist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set deflist [raw_def $id] + if {$deflist eq ""} { + return + } + return [resolve {*}$deflist] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + variable arg_error_CLR + array set arg_error_CLR {} + set arg_error_CLR(errormsg) [a+ brightred] + set arg_error_CLR(title) "" + set arg_error_CLR(check) [a+ brightgreen] + set arg_error_CLR(solo) [a+ brightcyan] + set arg_error_CLR(choiceprefix) [a+ underline] + set arg_error_CLR(badarg) [a+ brightred] + set arg_error_CLR(goodarg) [a+ green strike] + set arg_error_CLR(goodchoice) [a+ reverse] + set arg_error_CLR(linebase_header) [a+ white] + set arg_error_CLR(cmdname) [a+ brightwhite] + set arg_error_CLR(groupname) [a+ bold] + set arg_error_CLR(ansiborder) [a+ bold] + set arg_error_CLR(ansibase_header) [a+ bold] + set arg_error_CLR(ansibase_body) [a+ white] + variable arg_error_CLR_nocolour + array set arg_error_CLR_nocolour {} + set arg_error_CLR_nocolour(errormsg) [a+ bold] + set arg_error_CLR_nocolour(title) [a+ bold] + set arg_error_CLR_nocolour(check) "" + set arg_error_CLR_nocolour(solo) "" + set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment + set arg_error_CLR_nocolour(goodarg) [a+ strike] + set arg_error_CLR_nocolour(cmdname) [a+ bold] + set arg_error_CLR_nocolour(linebase_header) "" + set arg_error_CLR_nocolour(linebase) "" + set arg_error_CLR_nocolour(ansibase_body) "" + variable arg_error_CLR_info + array set arg_error_CLR_info {} + set arg_error_CLR_info(errormsg) [a+ brightred bold] + set arg_error_CLR_info(title) [a+ brightyellow bold] + set arg_error_CLR_info(check) [a+ brightgreen bold] + set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_info(groupname) [a+ cyan bold] + set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] + set arg_error_CLR_info(ansibase_header) [a+ cyan] + set arg_error_CLR_info(ansibase_body) [a+ white] + variable arg_error_CLR_error + array set arg_error_CLR_error {} + set arg_error_CLR_error(errormsg) [a+ brightred bold] + set arg_error_CLR_error(title) [a+ brightcyan bold] + set arg_error_CLR_error(check) [a+ brightgreen bold] + set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_error(groupname) [a+ cyan bold] + set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] + set arg_error_CLR_error(ansibase_header) [a+ yellow] + set arg_error_CLR_error(ansibase_body) [a+ white] + + + #bas ic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + upvar ::punk::args::arg_error_CLR CLR + + switch -- $scheme { + nocolour { + variable arg_error_CLR_nocolour + array set CLR [array get arg_error_CLR_nocolour + } + info { + variable arg_error_CLR_info + array set CLR [array get arg_error_CLR_info] + } + error { + variable arg_error_CLR_error + array set CLR [array get arg_error_CLR_error] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + #if {"$argdisplay_header$argdisplay_body" eq ""} { + # set is_custom_argdisplay 0 + #} else { + # set is_custom_argdisplay 1 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $form_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $form_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + #unhappy path - not enough options + #review - which form of punk::args::parse? + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + set id [lindex $tailargs 0] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + + 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-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } 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 + + #JJJJ + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$valmax == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $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 <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $valname_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $validx}] + } + #------------------------------------------ + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + 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 + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -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 + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.7 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index aaa595ae..2d949ccf 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates { namespace export * namespace eval class { variable PUNKARGS - #set argd [punk::args::get_dict { - # @id -id "::punk::cap::handlers::templates::class::api folders" - # -startdir -default "" - # @values -max 0 - #} $args] - lappend PUNKARGS [list { - @id -id "::punk::cap::handlers::templates::class::api folders" - -startdir -default "" - @values -max 0 - }] + #lappend PUNKARGS [list { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #}] oo::class create api { #return a dict keyed on folder with source pkg as value @@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates { set cname [string map {. _} $capname] set capabilityname $capname } + set class_ns [uplevel 1 [list namespace current]] + + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + @cmd -name "punk::cap::handlers::templates::class::api folders" + -startdir -default "" -help\ + "Defaults to CWD if not supplied" + @values -max 0 + }] method folders {args} { #puts "--folders $args" - set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] + set argd [punk::args::parse $args withid "[self class] folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates { } return $folderdict } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" + @cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\ + "" + @opts -anyopts 1 + #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here + -startdir -default "" + @values -maxvalues -1 + }] method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" - @opts -anyopts 1 - #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here - -startdir -default "" - @values -maxvalues -1 - } $args] + + set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"] + set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { @@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates { my _get_itemdict {*}$arglist } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" + @cmd -name _get_itemdict + @opts -anyopts 0 + -startdir -default "" + -templatefolder_subdir -optional 0 + -command_get_items_from_base -optional 0 + -command_get_item_name -optional 0 + -not -default "" -multiple 1 + @values -maxvalues -1 + globsearches -default * -multiple 1 + }] + #shared algorithm for get_itemdict_* methods #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" - @cmd -name _get_itemdict - @opts -anyopts 0 - -startdir -default "" - -templatefolder_subdir -optional 0 - -command_get_items_from_base -optional 0 - -command_get_item_name -optional 0 - -not -default "" -multiple 1 - @values -maxvalues -1 - globsearches -default * -multiple 1 - } $args] + set argd [punk::args::parse $args withid "[self class] _get_itemdict"] + set opts [dict get $argd opts] set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results #puts stderr "=-=============>globsearches:$globsearches" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm index e278d99f..3a5f25b0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -44,8 +44,11 @@ tcl::namespace::eval punk::config { @values -min 0 -max 0 }] proc dir {args} { + #set be_quiet [dict exists $received -quiet] if {"-quiet" in $args} { - set be_quiet [dict exists $received -quiet] + set be_quiet 1 + } else { + set be_quiet 0 } set was_noisy 0 @@ -445,6 +448,7 @@ tcl::namespace::eval punk::config { "Get configuration values from a config. Accepts globs eg XDG*" @leaders -min 1 -max 1 + #todo - load more whichconfig choices? whichconfig -type string -choices {config startup-configuration running-configuration} @values -min 0 -max -1 globkey -type string -default * -optional 1 -multiple 1 @@ -526,18 +530,23 @@ tcl::namespace::eval punk::config { error "setting value not implemented" } - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::config::show - @cmd -name punk::config::get -help\ - "Display configuration values from a config. - Accepts globs eg XDG*" - @leaders -min 1 -max 1 - }\ - {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ - "@values -min 0 -max -1"\ - {${[punk::args::resolved_def -types values ::punk::config::get]}}\ - ] + namespace eval argdoc { + set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}} + set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}} + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${$DYN_GET_LEADERS}}\ + "@values -min 0 -max -1"\ + {${$DYN_GET_VALUES}}\ + ] + } proc show {args} { #todo - tables for console set configrecords [punk::config::get {*}$args] @@ -568,7 +577,7 @@ tcl::namespace::eval punk::config { toconfig -help\ "running or startup or file name (not fully implemented)" } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::parse $args withdef $argdef] set fromconfig [dict get $argd values fromconfig] set toconfig [dict get $argd values toconfig] set fromconfig [string map {-config ""} $fromconfig] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index adb47eff..7d1375d7 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -562,13 +562,13 @@ namespace eval punk::du { proc Get_attributes_from_iteminfo {args} { variable win_reparse_tags_by_int - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::Get_attributes_from_iteminfo -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" - } $args] + }] set opts [dict get $argd opts] set iteminfo [dict get $argd values iteminfo] set opt_debug [dict get $opts -debug] @@ -621,14 +621,14 @@ namespace eval punk::du { proc attributes_twapi {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::attributes_twapi -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" - } $args] + }] set opts [dict get $argd opts] set path [dict get $argd values path] set opt_detail [dict get $opts -detail] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index ca222524..86126a5c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib { } proc range_boundaries {start end chunksizes args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { -offset -default 0 - } $args] + }] lassign [dict values $argd] leaders opts remainingargs } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm new file mode 100644 index 00000000..5532ed33 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm @@ -0,0 +1,4237 @@ +# -*- 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::lib 0.1.2 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::lib 0 0.1.2] +#[copyright "2024"] +#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk library}] [comment {-- Description at end of page heading --}] +#[require punk::lib] +#[keywords module utility lib] +#[description] +#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. +#[para]The base set includes string and math functions but has no specific theme + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::lib +#[subsection Concepts] +#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. +#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::lib +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +tcl::namespace::eval punk::lib::ensemble { + #wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + proc extend {routine extension} { + if {![string match ::* $routine]} { + set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![string match ::* $extension]} { + set extension [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$extension + } + + if {![tcl::namespace::exists $extension]} { + error [list {no such namespace} $extension] + } + + set extension [tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] current]] + + tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] export *] + + while 1 { + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] + if {[tcl::namespace::which $renamed] eq {}} break + } + + rename $routine $renamed + + tcl::namespace::eval $extension [ + list namespace ensemble create -command $routine -unknown [ + list apply {{renamed ensemble routine args} { + list $renamed $routine + }} $renamed + ] + ] + + return $routine + } +} + +# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated +tcl::namespace::eval punk::lib::check { + proc has_tclbug_script_var {} { + + set script {set j [list spud] ; list} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + return true + } else { + return false + } + } + proc has_tclbug_lsearch_strideallinline {} { + #bug only occurs with single -index value combined with -stride -all -inline -subindices + #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d + if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { + #we aren't looking for an error result - error most likely indicates tcl too old to support -stride + return 0 + } + return [expr {$result ne "a2"}] + } + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { + #ensemble calls within safe interp not compiled + namespace eval [namespace current]::testcompile { + proc ensembletest {} {string index a 0} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr has_bug + } + return $has_bug + } +} + +tcl::namespace::eval punk::lib::compat { + #*** !doctools + #[subsection {Namespace punk::lib::compat}] + #[para] compatibility functions for features that may not be available in earlier Tcl versions + #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. + #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. + + #*** !doctools + #[list_begin definitions] + + + + + if {"::lremove" ne [info commands ::lremove]} { + #puts stderr "Warning - no built-in lremove" + interp alias {} lremove {} ::punk::lib::compat::lremove + } + proc lremove {list args} { + #*** !doctools + #[call [fun lremove] [arg list] [opt {index ...}]] + #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove + + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 + + if {![info exists ::auto_index(readFile)]} { + if {[info commands ::readFile] eq ""} { + proc ::readFile {filename {mode text}} { + #readFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + + # Read the file + set f [open $filename [dict get {text r binary rb} $mode]] + try { + return [read $f] + } finally { + close $f + } + } + } + } + if {![info exists ::auto_index(writeFile)]} { + if {[info commands ::writeFile] eq ""} { + proc ::writeFile {args} { + #writeFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + switch [llength $args] { + 2 { + lassign $args filename data + set mode text + } + 3 { + lassign $args filename mode data + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + } + default { + set COMMAND [lindex [info level 0] 0] + return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" + } + } + + # Write the File + set f [open $filename [dict get {text w binary wb} $mode]] + try { + puts -nonewline $f $data + } finally { + close $f + } + } + } + } + + if {"::lpop" ne [info commands ::lpop]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lpop + } + proc lpop {lvar args} { + #*** !doctools + #[call [fun lpop] [arg listvar] [opt {index}]] + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + + + #slight isolation - varnames don't leak - but calling context vars can be affected + proc lmaptcl2 {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result [apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + if {"::lmap" ne [info commands ::lmap]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lmap {} ::punk::lib::compat::lmaptcl + } + #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway + proc lmaptcl {varnames list script} { + set result [list] + set varlist [list] + foreach varname $varnames { + upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc + lappend varlist var_$varname + } + foreach $varlist $list { + lappend result [uplevel 1 $script] + } + return $result + } + + #tcl8.7/9 compatibility for 8.6 + if {[info commands ::tcl::string::insert] eq ""} { + #https://wiki.tcl-lang.org/page/string+insert + # Pure Tcl implementation of [string insert] command. + proc ::tcl::string::insert {string index insertString} { + # Convert end-relative and TIP 176 indexes to simple integers. + if {[regexp -expanded { + ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace + |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace + (?:([+-]) # op, omitted when index is "end" + ([+-]?\d+))? # n, omitted when index is "end" + [\t\n\v\f\r ]*$ # optional whitespace (unless "end") + } $index _ m op n]} { + # Convert first index to an integer. + switch $m { + end {set index [string length $string]} + default {scan $m %d index} + } + + # Add or subtract second index, if provided. + switch $op { + + {set index [expr {$index + $n}]} + - {set index [expr {$index - $n}]} + } + } elseif {![string is integer -strict $index]} { + # Reject invalid indexes. + return -code error "bad index \"$index\": must be\ + integer?\[+-\]integer? or end?\[+-\]integer?" + } + + # Concatenate the pre-insert, insertion, and post-insert strings. + string cat [string range $string 0 [expr {$index - 1}]] $insertString\ + [string range $string $index end] + } + + # Bind [string insert] to [::tcl::string::insert]. + tcl::namespace::ensemble configure string -map [tcl::dict::replace\ + [tcl::namespace::ensemble configure string -map]\ + insert ::tcl::string::insert] + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::lib { + variable PUNKARGS + tcl::namespace::export * + variable has_struct_list + set has_struct_list [expr {![catch {package require struct::list}]}] + variable has_struct_set + set has_struct_set [expr {![catch {package require struct::set}]}] + variable has_punk_ansi + set has_punk_ansi [expr {![catch {package require punk::ansi}]}] + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + + #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) + proc aliases {{glob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + set ns_mapped [string map {:: \uFFFF} $ns] + #puts stderr "aliases ns: $ns_mapped" + set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: + if {![string length [lindex $segments end]]} { + #special case for :: only include leading segment rather thatn {} {} + set segments [lrange $segments 0 end-1] + } + set segcount [llength $segments] ;#only match number of segments matching current ns + + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + + set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" + if {($acount - 1) == $segcount} { + if {[lrange $asegs 0 end-1] eq $segments} { + if {[string match $glob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + + return $matched + } + + proc alias {{aliasorglob ""} args} { + set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + if {[llength $args]} { + if {$aliasorglob in [interp aliases ""]} { + set existing [interp alias "" $aliasorglob] + puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" + } + if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { + #use empty string/whitespace as intention to delete alias + return [interp alias "" $aliasorglob ""] + } + return [interp alias "" $aliasorglob "" {*}$args] + } else { + if {![string length $aliasorglob]} { + set aliaslist [punk::lib::aliases] + puts -nonewline stderr $aliaslist + return + } + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias + set target [interp alias "" $aliasorglob] + if {[llength $target]} { + return $target + } + + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { + set aliaslist [punk::lib::aliases $aliasorglob] + puts -nonewline stderr $aliaslist + return + } + return [list] + } + } + + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + + # -- --- + #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists + #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 + #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows + # Review and retest as new versions come out. + # -- --- + proc list_multi_append1 {lvar1 lvar2} { + #clear winner in 2024 + upvar $lvar1 l1 $lvar2 l2 + lappend l1 {*}$l2 + return $l1 + } + proc list_multi_append2 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [list {*}$l1 {*}$l2] + } + proc list_multi_append3 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] + } + #testing e.g + #set l1_reset {a b c} + #set l2 {a b c d e f g} + #set l1 $l1_reset + #time {list_multi_append1 l1 l2} 1000 + #set l1 $l1_reset + #time {list_multi_append2 l1 l2} 1000 + # -- --- + + + proc lswap {lvar a z} { + upvar $lvar l + if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} { + #lindex_resolve_basic returns only -1 if out of range + #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred + #(e.g using: lswap mylist end-2 end on a two element list) + + #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report + #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) + set a_index [lindex_resolve $l $a] + set a_msg "" + switch -- $a_index { + -2 { + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + } + -3 { + set a_msg "1st supplied index $a is below the lower bound for the list (0)" + } + } + set z_index [lindex_resolve $l $z] + set z_msg "" + switch -- $z_index { + -2 { + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } + -3 { + set z_msg "2nd supplied index $z is below the lower bound for the list (0)" + } + } + set errmsg "lswap cannot swap indices $a and $z" + if {$a_msg ne ""} { + append errmsg \n $a_msg + } + if {$z_msg ne ""} { + append errmsg \n $z_msg + } + error $errmsg + } + set item2 [lindex $l $z] + lset l $z [lindex $l $a] + lset l $a $item2 + return $l + } + #proc lswap2 {lvar a z} { + # upvar $lvar l + # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] + #} + + proc lswap2 {lvar a z} { + upvar $lvar l + #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] + } + + #an experimental test of swapping vars without intermediate variables + #It's an interesting idea - but probably of little to no practical use + # - the swap_intvars3 version using intermediate var is faster in Tcl + # - This is probably unsurprising - as it's simpler code. + # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. + #proc swap_intvars {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] + #} + #proc swap_intvars2 {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {$_x ^ $_y}] + # set _y [expr {$_x ^ $_y}] + # set _x [expr {$_x ^ $_y}] + #} + #proc swap_intvars3 {swapv1 swapv2} { + # #using intermediate variable + # upvar $swapv1 _x $swapv2 _y + # set z $_x + # set _x $_y + # set _y $z + #} + + #*** !doctools + #[subsection {Namespace punk::lib}] + #[para] Core API functions for punk::lib + #[list_begin definitions] + + 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 + #support minimal set from to + proc range {from to} { + lseq $from $to + } + } else { + #lseq accepts basic expressions e.g 4-2 for both arguments + #e.g we can do lseq 0 [llength $list]-1 + #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. + proc range {from to} { + set to [offset_expr $to] + set from [offset_expr $from] + if {$to > $from} { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + #slower methods. + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from] + #} + #return $L + } elseif {$from > $to} { + set count [expr {$from - $to} + 1] + #1) + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from -1];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from -1] + #} + #return $L + } else { + return [list $from] + } + } + } + + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + return $zip_l + } + #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible + if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { + #-stride either not available - or has bug preventing use of main algorithm below + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + } else { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + + + namespace import ::punk::args::lib::tstr + + + + proc invoke command { + #*** !doctools + #[call [fun invoke] [arg command]] + #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode + #[example { + # set script { + # puts stdout {hello on stdout} + # puts stderr {hello on stderr} + # exit 42 + # } + # invoke [list tclsh <<$script] + #}] + + #see https://wiki.tcl-lang.org/page/open + lassign [chan pipe] chanout chanin + lappend command 2>@$chanin + set fh [open |$command] + set stdout [read $fh] + close $chanin + set stderr [read $chanout] + close $chanout + if {[catch {close $fh} cres e]} { + dict with e {} + lassign [set -errorcode] sysmsg pid exit + if {$sysmsg eq {NONE}} { + #output to stderr caused [close] to fail. Do nothing + } elseif {$sysmsg eq {CHILDSTATUS}} { + return [list $stdout $stderr $exit] + } else { + return -options $e $stderr + } + } + return [list $stdout $stderr 0] + } + + proc pdict {args} { + package require punk::args + variable has_punk_ansi + if {!$has_punk_ansi} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } + set argspec [string map [list %sep% $sep] { + @id -id ::punk::lib::pdict + @cmd -name pdict -help\ + "Print dict keys,values to channel + The pdict function operates on variable names - passing the value to the showdict function which operates on values + (see also showdict)" + + @opts -any 1 + + #default separator to provide similarity to tcl's parray function + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} + -channel -default stdout -help\ + "existing channel - or 'none' to return as string" + + @values -min 1 -max -1 + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + Segments are classified into list,dict and string operations. + Leading % indicates a string operation - e.g %# gives string length + A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 + A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' + The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. + e.g1 pdict env */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segement in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + } + }] + #puts stderr "$argspec" + set argd [punk::args::parse $args withdef $argspec] + + set opts [dict get $argd opts] + set dvar [dict get $argd values dictvar] + set patterns [dict get $argd values patterns] + set isarray [uplevel 1 [list array exists $dvar]] + if {$isarray} { + set dvalue [uplevel 1 [list array get $dvar]] + if {![dict exists $opts -keytemplates]} { + set arrdisplay [string map [list %dvar% $dvar] {${[if {[lindex $key 1] eq "query"} {val "%dvar% [lindex $key 0]"} {val "%dvar%($key)"}]}}] + dict set opts -keytemplates [list $arrdisplay] + } + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } + showdict {*}$opts $dvalue {*}$patterns + } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality + proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) + #set sep " [a+ Web-seagreen]=[a] " + variable has_punk_ansi + if {!$has_punk_ansi} { + set RST "" + set sep " = " + set sep_mismatch " mismatch " + } else { + set RST [punk::ansi::a] + set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " + } + package require punk::pipe + #package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + @id -id ::punk::lib::showdict + @cmd -name punk::lib::showdict -help "display dictionary keys and values" + #todo - table tableobject + -return -default "tailtohead" -choices {tailtohead sidebyside} + -channel -default none + -trimright -default 1 -type boolean -help\ + "Trim whitespace off rhs of each line. + This can help prevent a single long line that wraps in terminal from making + every line wrap due to long rhs padding." + -separator -default {%sep%} -help\ + "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help\ + "Separator to use when patterns mismatch" + -roottype -default "dict" -help\ + "list,dict,string" + -ansibase_keys -default "" -help\ + "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} + -ansibase_values -default "" + -keytemplates -default {\$\{$key\}} -type list -help\ + "list of templates for keys at each level" + -keysorttype -default "none" -choices {none dictionary ascii integer real} + -keysortdirection -default increasing -choices {increasing decreasing} + -debug -default 0 -type boolean -help\ + "When enabled, produces some rudimentary debug output on stderr" + @values -min 1 -max -1 + dictvalue -type list -help\ + "dict or list value" + patterns -default "*" -type string -multiple 1 -help\ + "key or key glob pattern" + }]] + + #for punk::lib - we want to reduce pkg dependencies. + # - so we won't even use the tcllib debug pkg here + set opt_debug [dict get $argd opts -debug] + if {$opt_debug} { + if {[info body debug::showdict] eq ""} { + proc ::punk::lib::debug::showdict {args} { + catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} + } + } + } else { + if {[info body debug::showdict] ne ""} { + proc ::punk::lib::debug::showdict {args} {} + } + } + + set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] + set opt_keysorttype [dict get $argd opts -keysorttype] + set opt_keysortdirection [dict get $argd opts -keysortdirection] + set opt_trimright [dict get $argd opts -trimright] + set opt_keytemplates [dict get $argd opts -keytemplates] + debug::showdict "keytemplates ---> $opt_keytemplates <---" + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] + set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] + + set dval [dict get $argd values dictvalue] + set patterns [dict get $argd values patterns] + + set result "" + + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set pattern_this_structure [dict create] + + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + + set filtered_keys [list] + if {$opt_roottype in {dict list string}} { + #puts "getting keys for roottype:$opt_roottype" + if {[llength $dval]} { + set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$} + set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + foreach pattern_nest $patterns { + set keyset [list] + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + if {[string index $p 0] eq "!"} { + set get_not 1 + set p [string range $p 1 end] + } else { + set get_not 0 + } + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string + } + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + #todo get_not !# is test for listiness (see punk) + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + #puts "showdict ---->@*<----" + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {$get_not} { + if {[dict exists $dval $k]} { + set keys [dict keys [dict remove $dval $k]] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + lappend keyset {*}[dict keys $dval] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + } + } else { + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + } + dict set pattern_this_structure $p dict + } + @k@* - @K@* { + #TODO get_not + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + #TODO get_not + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string + lappend keyset $p + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + if {$get_not} { + set keys [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $keys $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset $p + lappend keyset_structure list + } + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high + #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds + if {${lower_resolve} == -2} { + ##x + #lower bound is above upper list range + #match with decreasing indices is still possible + set lower [expr {[llength $dval]-1}] ;#set to max + } elseif {$lower_resolve == -3} { + ##x + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve $dval $b] + if {$upper == -3} { + ##x + #upper bound is below list range - + if {$lower_resolve >=-2} { + ##x + set upper 0 + } else { + continue + } + } elseif {$upper == -2} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + if {$get_not} { + set fullrange [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $fullrange {*}$keys] + if {$lower > $upper} { + set keys [lreverse $keys] + } + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + if {$get_not} { + lappend keyset [list !@$p query] + } else { + lappend keyset [list @$p query] + } + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + if {$get_not} { + set keys [dict keys [dict remove $dval {*}$keys]] + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + } + } + } + } + + # -- --- --- --- + #check next pattern-segment for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $segments 1] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + #ignore the NOT operator for purposes of query-type detection + if {[string index $pnext 0] eq "!"} { + set pnext [string range $pnext 1 end] + } + # single type in segment e.g /@@something/ + switch -exact $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + } + } + } + } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + if {$opt_keysorttype ne "none"} { + set int_keyset 1 + foreach k $keyset { + if {![string is integer -strict $k]} { + set int_keyset 0 + break + } + } + if {$int_keyset} { + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] + } else { + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] + } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] + } + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + + lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure + + #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" + } + } + #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" + } else { + puts stdout "unrecognised roottype: $opt_roottype" + return $dval + } + + if {[llength $filtered_keys]} { + #both keys and values could have newline characters. + #simple use of 'format' won't cut it for more complex dict keys/values + #use block::width or our columns won't align in some cases + switch -- $opt_return { + "tailtohead" { + #last line of key is side by side (possibly with separator) with first line of value + #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values + #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt {${$key}} + } + #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + set last_hidekey 0 + foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" + set hidekey 0 + set pattern_nest [lindex $pattern_key_index $kidx] + set pattern_nest_list [split $pattern_nest /] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" + + set is_match 1 ;#whether to display the normal separator or bad-match separator + switch -- $this_type { + dict { + #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + % thisval.= $qry= $dval + } else { + set thisval [tcl::dict::get $dval $key] + } + + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" + set is_match 0 + } + } + } + list { + if {[string is integer -strict $key]} { + set thisval [lindex $dval $key] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + % thisval.= $qry= $dval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + #if {![llength $nextpatterns]} { + # set nextpatterns * + #} + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + set is_match 0 + } + } + } + string { + set hidekey 1 + if {$key eq "%string"} { + set hidekey 1 + set thisval $dval + } elseif {$key eq "%ansiview"} { + set thisval [ansistring VIEW -lf 1 $dval] + } elseif {$key eq "%ansiviewstyle"} { + set thisval [ansistring VIEWSTYLE -lf 1 $dval] + } elseif {[string match *lpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] + } elseif {[string match *rpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + set thisval $dval + if {[string index $key 0] ne "%"} { + set key %$key + } + % thisval.= $key= $thisval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + #set nextopts [dict get $argd opts] + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + if {[llength $nextpatterns]} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } + } + if {$this_type eq "string" && $hidekey} { + lassign [textblock::size $thisval] _vw vwidth _vh vheight + #set blanks_above [string repeat \n [expr {$kheight -1}]] + set vblock $opt_ansibase_values$thisval$RST + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" + } else { + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + + set totalheight [expr {$kheight + $vheight -1}] + set blanks_above [string repeat \n [expr {$kheight -1}]] + set blanks_below [string repeat \n [expr {$vheight -1}]] + + if {$is_match} { + set use_sep $opt_sep + } else { + set use_sep $opt_mismatch_sep + } + + + set sepwidth [textblock::width $use_sep] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] + set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] + set vblock $blanks_above$opt_ansibase_values$thisval$RST + #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } + append result [textblock::join_basic -- $kblock $sblock $vblock] \n + } + set last_hidekey $hidekey + incr kidx + } + } + "sidebyside" { + # TODO - fix + #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. + #use ansibase_key etc to make the output more comprehensible in that situation. + #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] + foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST + #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n + #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n + } + } + } + } + if {$opt_trimright} { + set result [::join [lines_as_list -line trimright $result] \n] + } + if {[string last \n $result] == [string length $result]-1} { + set result [string range $result 0 end-1] + } + #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) + set chan [dict get $argd opts -channel] + switch -- $chan { + stderr - stdout { + puts $chan $result + } + none { + return $result + } + default { + #review - check member of chan names? + #just try outputting to the supplied channel for now + puts $chan $result + } + } + } + + proc is_list_all_in_list {small large} { + set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] + return [struct::list equal [lsort $small] $small_in_large] + } + if {!$has_struct_list || !$has_struct_set} { + set body { + package require struct::list + package require struct::set + } + append body [info body is_list_all_in_list] + proc is_list_all_in_list {small large} $body + } + + proc is_list_all_ni_list {a b} { + set i [struct::set intersect $a $b] + return [expr {[llength $i] == 0}] + } + if {!$has_struct_set} { + set body { + package require struct::list + } + append body [info body is_list_all_ni_list] + proc is_list_all_ni_list {a b} $body + } + + #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist + #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, + # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) + proc ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + proc ldiff2 {fromlist removeitems} { + set doomed [list] + foreach item $removeitems { + lappend doomed {*}[lsearch -all -exact $fromlist $item] + } + lremove $fromlist {*}$doomed + } + + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) + #also struct::set difference with critcl is faster + proc setdiff {A B} { + if {[llength $A] == 0} {return {}} + set d [dict create] + foreach x $A {dict set d $x {}} + foreach x $B {dict unset d $x} + return [dict keys $d] + } + #bulk dict remove is slower than a foreach with dict unset + #proc setdiff2 {fromlist removeitems} { + # #if {[llength $fromlist] == 0} {return {}} + # set d [dict create] + # foreach x $fromlist { + # dict set d $x {} + # } + # return [dict keys [dict remove $d {*}$removeitems]] + #} + #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) + proc setdiff_unordered {A B} { + if {[llength $A] == 0} {return {}} + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] + } + + #default/fallback implementation + proc lunique_unordered {list} { + lunique $list + } + if {$has_struct_set} { + if {[struct::set equal [struct::set union {a a} {}] {a}]} { + proc lunique_unordered {list} { + struct::set union $list {} + } + } else { + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add + } + } + + + #order-preserving + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + proc lunique2 {list} { + set doomed [list] + #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) + for {set i 0} {$i < [llength $list]} {} { + set item [lindex $list $i] + lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] + while {[incr i] in $doomed} {} + } + lremove $list {*}$doomed + } + #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env + proc lmapflat_closure {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + # -- --- --- + #capture - use uplevel 1 or namespace eval depending on context + set capture [uplevel 1 { + apply { varnames { + set capturevars [tcl::dict::create] + set capturearrs [tcl::dict::create] + foreach fullv $varnames { + set v [tcl::namespace::tail $fullv] + upvar 1 $v var + if {[info exists var]} { + if {(![array exists var])} { + tcl::dict::set capturevars $v $var + } else { + tcl::dict::set capturearrs capturedarray_$v [array get var] + } + } else { + #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set + } + } + return [tcl::dict::create vars $capturevars arrs $capturearrs] + } } [info vars] + } ] + # -- --- --- + set cvars [tcl::dict::get $capture vars] + set carrs [tcl::dict::get $capture arrs] + set apply_script "" + foreach arrayalias [tcl::dict::keys $carrs] { + set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { + array set %realname% [set %arrayalias%][unset %arrayalias%] + }] + } + + append apply_script [string map [list %script% $script] { + #foreach arrayalias [info vars capturedarray_*] { + # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + # array set $realname [set $arrayalias][unset arrayalias] + #} + #return [eval %script%] + %script% + }] + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ + $apply_script\ + ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] + } + return $result + } + #link version - can write to vars in calling context - but keeps varnames themselves isolated + #performance much better than capture version - but still a big price to pay for the isolation + proc lmapflat_link {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + #proc lmapflat {varnames list script} { + # concat {*}[uplevel 1 [list lmap $varnames $list $script]] + #} + #lmap can accept multiple var list pairs + proc lmapflat {args} { + concat {*}[uplevel 1 [list lmap {*}$args]] + } + proc lmapflat2 {args} { + concat {*}[uplevel 1 lmap {*}$args] + } + + #proc dict_getdef {dictValue args} { + # if {[llength $args] < 1} { + # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} + # } + # set keys [lrange $args -1 end-1] + # if {[tcl::dict::exists $dictValue {*}$keys]} { + # return [tcl::dict::get $dictValue {*}$keys] + # } else { + # return [lindex $args end] + # } + #} + 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::lib::dict_getdef "" ::tcl::dict::getdef + } + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side + proc lindex_resolve {list index} { + #*** !doctools + #[call [fun lindex_resolve] [arg list] [arg index]] + #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list + #[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl. + #[para]This means the proc may be called with something like $x+2 end-$y etc + #[para]Sometimes the actual integer index is desired. + #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. + #[para]lindex_resolve will parse the index expression and return: + #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) + #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) + #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list + #[para]Otherwise it will return an integer corresponding to the position in the list. + #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. + #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable + #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 + + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr + #if {![llength $list]} { + # #review + # return ??? + #} + set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + if {$index < 0} { + return -3 + } elseif {$index >= [llength $list]} { + return -2 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$op eq "+" && $offset != 0} { + return -2 + } + } else { + #index is 'end' + set index [expr {[llength $list]-1}] + if {$index < 0} { + #special case - 'end' with empty list - treat end like a positive number out of bounds + return -2 + } else { + return $index + } + } + if {$offset == 0} { + set index [expr {[llength $list]-1}] + if {$index < 0} { + return -2 ;#special case as above + } else { + return $index + } + } else { + #by now, if op = + then offset = 0 so we only need to handle the minus case + set index [expr {([llength $list]-1) - $offset}] + } + if {$index < 0} { + return -3 + } else { + return $index + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < 0} { + return -3 + } elseif {$index >= [llength $list]} { + return -2 + } + return $index + } + } + } + proc lindex_resolve_basic {list index} { + #*** !doctools + #[call [fun lindex_resolve_basic] [arg list] [arg index]] + #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) + #[para] returns -1 for out of range at either end, or a valid integer index + #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound + #[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command + #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 + #[para] For pure integer indices the performance should be equivalent + + #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ + # - which + #for {set i 0} {$i < [llength $list]} {incr i} { + # lappend indices $i + #} + set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + #avoid even the lseq overhead when the index is simple + if {$index < 0 || ($index >= [llength $list])} { + #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. + return -1 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } + if {[llength $list]} { + set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + } else { + set indices [list] + } + set idx [lindex $indices $index] + if {$idx eq ""} { + #we have no way to determine if out of bounds is at lower vs upper end + return -1 + } else { + return $idx + } + } + proc lindex_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [tcl::dict::create value [lindex $resultlist 0]] + } + } + + + proc K {x y} {return $x} + #*** !doctools + #[call [fun K] [arg x] [arg y]] + #[para]The K-combinator function - returns the first argument, x and discards y + #[para]see [uri https://wiki.tcl-lang.org/page/K] + #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + + + proc is_utf8_multibyteprefix {bytes} { + #*** !doctools + #[call [fun is_utf8_multibyteprefix] [arg str]] + #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character + #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint + #[para] Will return false for an already complete utf-8 codepoint + #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument + #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes + #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] + regexp {(?x) + ^ + (?: + [\xC0-\xDF] | #possible prefix for two-byte codepoint + [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for + ) + $ + } $bytes + } + + proc is_utf8_first {str} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + } $str + } + proc is_utf8_single {1234bytes} { + #*** !doctools + #[call [fun is_utf8_single] [arg 1234bytes]] + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + $ + } $1234bytes + } + proc get_utf8_leading {rawbytes} { + #*** !doctools + #[call [fun get_utf8_leading] [arg rawbytes]] + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint + #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. + #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. + #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics + #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned + #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes + if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $rawbytes completeChars]} { + return $completeChars + } + return "" + } + proc hex2dec {args} { + #*** !doctools + #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] + #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values + #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 + #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. + #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 + #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 + + set list_largeHex [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" + } + set opts [tcl::dict::create\ + -validate 1\ + -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $opts] + foreach {k v} $argopts { + tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v + } + # -- --- --- --- + set opt_validate [tcl::dict::get $opts -validate] + set opt_empty [tcl::dict::get $opts -empty_as_hex] + # -- --- --- --- + + set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] + if {$opt_validate} { + #Note appended F so that we accept list of empty strings as per the documentation + if {![string is xdigit -strict [join $list_largeHex ""]F ]} { + error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" + } + } + if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { + #mapping empty string to a value destroys any advantage of -scanonly + #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] + if {[lsearch $list_largeHex ""] >=0} { + error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" + } + } else { + set opt_empty [string trim [string map {_ ""} $opt_empty]] + if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] + set nonempty_head [lrange $list_largeHex 0 $first_empty-1] + set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] + } + + proc dec2hex {args} { + #*** !doctools + #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] + #[para]Convert a list of decimal integers to a list of hex values + #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. + #[para] -case upper|lower determines the case of the hex letters in the output + set list_decimals [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" + } + set defaults [tcl::dict::create\ + -width 1\ + -case upper\ + -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $defaults] + set fullopts [tcl::dict::create] + foreach {k v} $argopts { + tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v + } + set opts [tcl::dict::merge $defaults $fullopts] + # -- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_case [tcl::dict::get $opts -case] + set opt_empty [tcl::dict::get $opts -empty_as_decimal] + # -- --- --- --- + + + set resultlist [list] + switch -- [string tolower $opt_case] { + upper { + set spec X + } + lower { + set spec x + } + default { + error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" + } + } + set fmt "%${opt_width}.${opt_width}ll${spec}" + + set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] + if {![string is digit -strict [string map {_ ""} $opt_empty]]} { + if {[lsearch $list_decimals ""] >=0} { + error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" + } + } else { + set opt_empty [string map {_ ""} $opt_empty] + if {[set first_empty [lsearch $list_decimals ""]] >= 0} { + set nonempty_head [lrange $list_decimals 0 $first_empty-1] + set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] + } + + proc log2 x "expr {log(\$x)/[expr log(2)]}" + #*** !doctools + #[call [fun log2] [arg x]] + #[para]log base2 of x + #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time + #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) + + proc logbase {b x} { + #*** !doctools + #[call [fun logbase] [arg b] [arg x]] + #[para]log base b of x + #[para]This function uses expr's natural log and the change of base division. + #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 + expr {log($x)/log($b)} + } + proc factors {x} { + #*** !doctools + #[call [fun factors] [arg x]] + #[para]Return a sorted list of the positive factors of x where x > 0 + #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* + #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors + #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + #[para]Comparisons were done with some numbers below 17 digits long + #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers + #but has the disadvantage of being slower for 'small' numbers and using more memory. + #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x + #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + #[para] In other mathematical contexts zero may be considered not to divide anything. + set factors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {($x % $j) == 0} { + lappend factors $j [expr {$x / $j}] + } + incr j + } + lappend factors $x + return [lsort -unique -integer $factors] + } + proc oddFactors {x} { + #*** !doctools + #[call [fun oddFactors] [arg x]] + #[para]Return a list of odd integer factors of x, sorted in ascending order + set j 2 + set max [expr {sqrt($x)}] + set factors [list 1] + while {$j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2} { + if {$other ni $factors} { + lappend factors $other + } + } + if {$j % 2} { + if {$j ni $factors} { + lappend factors $j + } + } + } + incr j + } + return [lsort -integer -increasing $factors] + } + proc greatestFactorBelow {x} { + #*** !doctools + #[call [fun greatestFactorBelow] [arg x]] + #[para]Return the largest factor of x excluding itself + #[para]factor functions can be useful for console layout calculations + #[para]See Tcllib math::numtheory for more extensive implementations + if {$x % 2 == 0 || $x == 0} { + return [expr {$x / 2}] + } + set j 3 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {$x % $j == 0} { + return [expr {$x / $j}] + } + incr j 2 + } + return 1 + } + proc greatestOddFactorBelow {x} { + #*** !doctools + #[call [fun greatestOddFactorBelow] [arg x]] + #[para]Return the largest odd integer factor of x excluding x itself + if {$x %2 == 0} { + return [greatestOddFactor $x] + } + set j 3 + #dumb brute force - time taken to compute is wildly variable on big numbers + #todo - use a (memoized?) generator of primes to reduce the search space + #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. + set god 1 + set max [expr {sqrt($x)}] + while { $j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2 == 0} { + set god $j + } else { + set god [expr {$x / $j}] + #lowest j - so other side must be highest + break + } + } + incr j 2 + } + return $god + } + proc greatestOddFactor {x} { + #*** !doctools + #[call [fun greatestOddFactor] [arg x]] + #[para]Return the largest odd integer factor of x + #[para]For an odd value of x - this will always return x + if {$x % 2 != 0 || $x == 0} { + return $x + } + set r [expr {$x / 2}] + while {$r % 2 == 0} { + set r [expr {$r / 2}] + } + return $r + } + proc gcd {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the greatest common divisor of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para]Graphical use: + #[para]An a by b rectangle can be covered with square tiles of side-length c, + #[para]only if c is a common divisor of a and b + + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m + } + proc lcm {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the lowest common multiple of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para] + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] + } + proc commonDivisors {x y} { + #*** !doctools + #[call [fun commonDivisors] [arg x] [arg y]] + #[para]Return a list of all the common factors of x and y + #[para](equivalent to factors of their gcd) + return [factors [gcd $x $y]] + } + + #experimental only - there are better/faster ways + proc sieve n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + tcl::dict::for {next -} $nums break + } + return [concat $primes [tcl::dict::keys $nums]] + } + proc sieve2 n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + #dict for {next -} $nums break + set next [lindex $nums 0] + } + return [concat $primes [tcl::dict::keys $nums]] + } + + proc hasglobs {str} { + #*** !doctools + #[call [fun hasglobs] [arg str]] + #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] + #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. + regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving + } + + proc trimzero {number} { + #*** !doctools + #[call [fun trimzero] [arg number]] + #[para]Return number with left-hand-side zeros trimmed off - unless all zero + #[para]If number is all zero - a single 0 is returned + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + proc substring_count {str substring} { + #*** !doctools + #[call [fun substring_count] [arg str] [arg substring]] + #[para]Search str and return number of occurrences of substring + + #faster than lsearch on split for str of a few K + if {$substring eq ""} {return 0} + set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] + return [expr {$occurrences / [string length $substring]}] + } + + proc dict_merge_ordered {defaults main} { + #*** !doctools + #[call [fun dict_merge_ordered] [arg defaults] [arg main]] + #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. + #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. + #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. + + #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] + } + + proc askuser {question} { + #*** !doctools + #[call [fun askuser] [arg question]] + #[para]A basic utility to read an answer from stdin + #[para]The prompt is written to the terminal and then it waits for a user to type something + #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. + #[para](Generic terminal raw vs linemode detection not yet present) + #[para]The user must hit enter to submit the response + #[para]The return value is the string if any that was typed prior to hitting enter. + #[para]The question argument can be manually colourised using the various punk::ansi funcitons + #[example_begin] + # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] + # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { + # puts "Proceeding" + # } else { + # puts "Cancelled by user" + # } + #[example_end] + puts stdout $question + flush stdout + set stdin_state [chan configure stdin] + if {[catch { + package require punk::console + set console_raw [tsv::get console is_raw] + } err_console]} { + #assume normal line mode + set console_raw 0 + } + try { + chan configure stdin -blocking 1 + if {$console_raw} { + punk::console::disableRaw + set answer [gets stdin] + punk::console::enableRaw + } else { + set answer [gets stdin] + } + } finally { + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] + } + return $answer + } + + #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] + } + #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 + } + + #e.g linesort -decreasing $data + proc linesort {args} { + #*** !doctools + #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] + #[para]Sort lines in textblock + #[para]Returns another textblock with lines sorted + #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique + if {[llength $args] < 1} { + error "linesort missing lines argument" + } + set lines [lindex $args end] + set opts [lrange $args 0 end-1] + #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts + list_as_lines [lsort {*}$opts [linelist $lines]] + } + + proc list_as_lines {args} { + #*** !doctools + #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] + #[para]This simply joins the elements of the list with -joinchar + #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines + #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. + if {[set eop [lsearch $args --]] == [llength $args]-2} { + #end-of-opts not really necessary - except for consistency with lines_as_list + set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] + } + if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { + set joinchar [lindex $args 1] + set lines [lindex $args 2] + } elseif {[llength $args] == 1} { + set joinchar "\n" + set lines [lindex $args 0] + } else { + error "list_as_lines usage: list_as_lines ?-joinchar ? " + } + return [join $lines $joinchar] + } + proc list_as_lines2 {args} { + #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? + lassign [tcl::dict::values [punk::args::parse $args withdef { + -joinchar -default \n + @values -min 1 -max 1 + }]] leaders opts values + + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + } + + proc lines_as_list {args} { + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. + #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error + #..because we don't know what to say if there are odd numbers of args + #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work + #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway + + if {[lsearch $args "--"] == [llength $args]-2} { + set opts [lrange $args 0 end-2] + } else { + set opts [lrange $args 0 end-1] + } + #set opts [tcl::dict::merge {-block {}} $opts] + set bposn [lsearch $opts -block] + if {$bposn < 0} { + lappend opts -block {} + } + set text [lindex $args end] + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] + } + #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds + proc lines_as_list2 {args} { + #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults + #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc + #we don't have to decide what is an opt vs a value + #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) + lassign [tcl::dict::values [punk::args::parse $args withdef { + @opts -any 1 + -block -default {} + }]] leaderdict opts valuedict + tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] + } + + # important for pipeline & match_assign + # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? + # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace + set linelist_body { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach code $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + #not sure if this handles more complex hierarchies or mixins etc. + lassign $args obj method + if {![info object isa object $obj]} { + error "show_jump_tables unable to examine '$args'. $obj is not an oo object" + } + #classes are objects too and can have direct methods + if {$method in [info object methods $obj]} { + set data [tcl::unsupported::disassemble objmethod $obj $method] + } else { + if {![info object isa class $obj]} { + set obj [info object class $obj] + } + set data [tcl::unsupported::disassemble method $obj $method] + } + } else { + error "show_jump_tables expected a procname or a class/object and method" + } + set result "" + set in_jt 0 + foreach ln [split $data \n] { + set tln [string trim $ln] + if {!$in_jt} { + if {[string match *jumpTable* $ln]} { + append result $ln \n + set in_jt 1 + } + } else { + if {[string match Command* $tln] || [string match "(*) *" $tln]} { + set in_jt 0 + } else { + append result $ln \n + } + } + } + return $result + } + + proc temperature_f_to_c {deg_fahrenheit} { + return [expr {($deg_fahrenheit -32) * (5/9.0)}] + } + proc temperature_c_to_f {deg_celsius} { + return [expr {($deg_celsius * (9/5.0)) + 32}] + } + + proc interp_sync_package_paths {interp} { + if {![interp exists $interp]} { + error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" + } + interp eval $interp [list set ::auto_path $::auto_path] + interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} + interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] + } + + proc objclone {obj} { + append obj2 $obj {} + } + proc set_clone {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + + + proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { + variable has_twapi + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + } + } + #when using twapi we currently only get the localeid - not the specific defaults + #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this + set default_delim "," + set default_groupsize 3 + + set results [list] + set nums [objclone $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + foreach inputnum $nums { + set number [objclone $inputnum] + #also handle tcl 8.7+ underscores in numbers + set number [string map [list _ "" , ""] $number] + #normalize e.g 2e4 -> 20000.0 + set number [expr {$number}] + + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + lappend results [twapi::format_number $number $localeid -idigits -1] + continue + } else { + #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one + #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? + if {$delim eq ""} {set delim $default_delim} + if {$groupsize eq ""} {set groupsize $default_groupsize} + lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + continue + } + } + #todo - get configured user defaults + if {$delim eq ""} { + set delim $default_delim + } + if {$groupsize eq ""} { + set groupsize $default_groupsize + } + + lappend results [delimit_number $number $delim $groupsize] + } + + if {[llength $results] == 1} { + #keep intrep as string rather than list + return [lindex $results 0] + } + return $results + } + + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { + set number [objclone $unformattednumber] + set number [string map {_ ""} $number] + #normalize using expr - e.g 2e4 -> 20000.0 + set number [expr {$number}] + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number $point+1 end]; + set PostDecimalP 1; + } else { + set point [expr {[string length $number] + 1}] + set PostDecimal ""; + set PostDecimalP 0; + } + + # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr {$FirstNonSpace - 1}]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace $point-1]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize + } + + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} + +tcl::namespace::eval punk::lib::test { + + + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#todo - way to generate 'internal' docs separately? +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::lib::system { + #*** !doctools + #[subsection {Namespace punk::lib::system}] + #[para] Internal functions that are not part of the API + #[list_begin definitions] + + + proc mostFactorsBelow {n} { + ##*** !doctools + #[call [fun mostFactorsBelow] [arg n]] + #[para]Find the number below $n which has the greatest number of factors + #[para]This will get slow quickly as n increases (100K = 1s+ 2024) + set most 0 + set mostcount 0 + for {set i 1} {$i < $n} {incr i} { + set fc [llength [punk::lib::factors $i]] + if {$fc > $mostcount} { + set most $i + set mostcount $fc + } + } + return [list number $most numfactors $mostcount] + } + proc factorCountBelow_punk {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [punk::lib::factors $i]] + } + return $tally + } + proc factorCountBelow_numtheory {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) + package require math::numtheory + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [math::numtheory::factors $i]] + } + return $tally + } + + proc factors2 {x} { + ##*** !doctools + #[call [fun factors2] [arg x]] + #[para]Return a sorted list of factors of x + #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. + set smallfactors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j < $max} { + if {($x % $j) == 0} { + lappend smallfactors $j + lappend largefactors [expr {$x / $j}] + } + incr j + } + #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop + if {($x % $j) == 0} { + if {$j == ($x / $j)} { + lappend smallfactors $j + } + } + return [concat $smallfactors [lreverse $largefactors] $x] + } + + + + # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + set i 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + incr i + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) + switch -- $c { + {"} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } + {[} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "{" { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "}" - + default { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + incr i + } + set incomplete [list] + foreach w $waiting { + #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. + switch -- $w { + {"} { + lappend incomplete $w + } + {]} { + lappend incomplete "\[" + } + "{" {} + "}" { + lappend incomplete "\{" + } + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->awaiting:'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + + #get info about punk nestindex key ie type: list,dict,undetermined + # pdict devel + proc nestindex_info {args} { + set argd [punk::args::parse $args withdef { + -parent -default "" + nestindex + }] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + #??? + + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] +} + +tcl::namespace::eval punk::lib::debug { + proc showdict {args} {} +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::lib +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::lib [tcl::namespace::eval punk::lib { + variable pkg punk::lib + variable version + set version 0.1.2 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm new file mode 100644 index 00000000..6f01e340 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -0,0 +1,1061 @@ +# -*- tcl -*- +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::libunknown 0.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::libunknown 0.1] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::libunknown] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::libunknown +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::libunknown +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + +tcl::namespace::eval punk::libunknown { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::libunknown}] + #[para] Core API functions for punk::libunknown + #[list_begin definitions] + + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + lappend PUNKARGS [list { + @id -id "(package)punk::libunknown" + @package -name "punk::libunknown" -help\ + "Experimental set of replacements for default 'package unknown' entries." + }] + + variable epoch + if {![info exists epoch]} { + set tmstate [dict create 0 {}] + set pkgstate [dict create 0 {}] + set tminfo [dict create current 0 epochs $tmstate] + set pkginfo [dict create current 0 epochs $pkgstate] + + set epoch [dict create tm $tminfo pkg $pkginfo] + } + + variable has_package_files + if {[catch {package files foobaz}]} { + set has_package_files 0 + } else { + set has_package_files 1 + } + + if {[info commands ::tcl::Pkg::source] ne ""} { + interp alias "" ::punk::libunknown::tcl_Pkg_source "" ::tcl::Pkg::source + } else { + #early 8.6 - pre tip459? + #we don't have + #::source -nopkg + proc tcl_Pkg_source {filename} { + uplevel 1 [list ::source $filename] + } + } + + #will use standard mechanism for non zipfs paths in the tm list. + proc zipfs_tm_UnknownHandler {original name args} { + # Import the list of paths to search for packages in module form. + # Import the pattern used to check package names in detail. + variable epoch + set pkg_epoch [dict get $epoch tm current] + + + #variable paths + upvar ::tcl::tm::paths paths + #variable pkgpattern + upvar ::tcl::tm::pkgpattern pkgpattern + + # Without paths to search we can do nothing. (Except falling back to the + # regular search). + set tid [format %-19s -] + catch {set tid [thread::id]} + + if {[llength $paths]} { + set pkgpath [string map {:: /} $name] + set pkgroot [file dirname $pkgpath] + if {$pkgroot eq "."} { + set pkgroot "" + } + + # We don't remember a copy of the paths while looping. Tcl Modules are + # unable to change the list while we are searching for them. This also + # simplifies the loop, as we cannot get additional directories while + # iterating over the list. A simple foreach is sufficient. + + if {[info commands ::tcl::zipfs::root] ne ""} { + set zipfsroot [tcl::zipfs::root] + set has_zipfs 1 + } else { + set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands + set has_zipfs 0 + } + + set satisfied 0 + foreach path $paths { + if {![interp issafe] && ![file exists $path]} { + continue + } + set currentsearchpath [file join $path $pkgroot] + + # Get the module files out of the subdirectories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. + + set use_epoch_for_all 1 + if {$use_epoch_for_all || [string match $zipfsroot* $path]} { + if {[dict exists $epoch tm epochs $pkg_epoch indexes $currentsearchpath]} { + #indexes are actual .tm files here + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" + } else { + + if {![interp issafe] && ![file exists $currentsearchpath]} { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + continue + } + + + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + + # ################################################################# + if {$has_zipfs && [string match $zipfsroot* $path]} { + set tmfiles [::tcl::zipfs::list $currentsearchpath/*.tm] ;#could theoretically be a dir - this is effectively a tree traversal + foreach tm_path $tmfiles { + dict set epoch tm epochs $pkg_epoch indexes [file dirname $tm_path] $tm_path $pkg_epoch + } + #retrieval using tcl::zipfs::list got (and cached) extras - limit to currentsearchpath + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + } else { + set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] + foreach tm_path $tmfiles { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $tm_path $pkg_epoch + } + } + #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles (UNcached): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" + + # ################################################################# + } + if {![llength $tmfiles]} { + continue + } + + # like normal processing - but track added (for static zipfs) + + set can_skip_update 0 + if {[string match $zipfsroot* $path]} { + #static tm location + if {[dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath]} { + if {![dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath $name]} { + #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. + #puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP orig:$original name:$name args:$args searchpath:$currentsearchpath" + set can_skip_update 1 + } else { + #if this name is in 'added' then we must have done something like a package forget or it wouldn't come back to package unknown + #dict unset epoch tm epochs $pkg_epoch added $currentsearchpath $name + } + } + } else { + #dynamic - can only skip if negatively cached for the current epoch + if {[dict exists $epoch tm epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_update 1 + } + + } + + if {!$can_skip_update} { + set strip [llength [file split $path]] + set found_name_in_currentsearchpath 0 ;#for negative cache by epoch + catch { + foreach file $tmfiles { + set pkgfilename [join [lrange [file split $file] $strip end] ::] + + if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { + # Ignore everything not matching our pattern for + # package names. + continue + } + try { + package vcompare $pkgversion 0 + } on error {} { + # Ignore everything where the version part is not + # acceptable to "package vcompare". + continue + } + + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. + continue + } + + # We have found a candidate, generate a "provide script" + # for it, and remember it. Note that we are using ::list + # to do this; locally [list] means something else without + # the namespace specifier. + + # NOTE. When making changes to the format of the provide + # command generated below CHECK that the 'LOCATE' + # procedure in core file 'platform/shell.tcl' still + # understands it, or, if not, update its implementation + # appropriately. + # + # Right now LOCATE's implementation assumes that the path + # of the package file is the last element in the list. + + package ifneeded $pkgname $pkgversion \ + "[::list package provide $pkgname $pkgversion];[::list source $file]" + + #JMN + #store only once for each name, although there may be multiple versions + dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkg_epoch + + # We abort in this unknown handler only if we got a + # satisfying candidate for the requested package. + # Otherwise we still have to fallback to the regular + # package search to complete the processing. + + if {($pkgname eq $name) + && [package vsatisfies $pkgversion {*}$args]} { + set satisfied 1 + + # We do not abort the loop, and keep adding provide + # scripts for every candidate in the directory, just + # remember to not fall back to the regular search + # anymore. + #(obsolete for libunknown - review) + } + + if {$pkgname eq $name} { + #can occur multiple times, different versions + #record package name as found in this path whether version satisfies or not + set found_name_in_currentsearchpath 1 + } + } + } + if {!$found_name_in_currentsearchpath} { + #can record as unfound for this path - for this epoch + dict set epoch tm epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + } + + } else { + #non zipfs tm path - normal processing + # We always look for _all_ possible modules in the current + # path, to get the max result out of the glob. + set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] + set strip [llength [file split $path]] + catch { + foreach file $tmfiles { + set pkgfilename [join [lrange [file split $file] $strip end] ::] + + if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { + # Ignore everything not matching our pattern for + # package names. + continue + } + try { + package vcompare $pkgversion 0 + } on error {} { + # Ignore everything where the version part is not + # acceptable to "package vcompare". + continue + } + + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. + continue + } + + # We have found a candidate, generate a "provide script" + # for it, and remember it. Note that we are using ::list + # to do this; locally [list] means something else without + # the namespace specifier. + + # NOTE. When making changes to the format of the provide + # command generated below CHECK that the 'LOCATE' + # procedure in core file 'platform/shell.tcl' still + # understands it, or, if not, update its implementation + # appropriately. + # + # Right now LOCATE's implementation assumes that the path + # of the package file is the last element in the list. + + package ifneeded $pkgname $pkgversion \ + "[::list package provide $pkgname $pkgversion];[::list source $file]" + + # We abort in this unknown handler only if we got a + # satisfying candidate for the requested package. + # Otherwise we still have to fallback to the regular + # package search to complete the processing. + + if {($pkgname eq $name) + && [package vsatisfies $pkgversion {*}$args]} { + set satisfied 1 + + # We do not abort the loop, and keep adding provide + # scripts for every candidate in the directory, just + # remember to not fall back to the regular search + # anymore. + } + } + } + + } + ##ZZZ + + } + + if {$satisfied} { + ##return + } + } + + # Fallback to previous command, if existing. See comment above about + # ::list... + + if {[llength $original]} { + #puts "zipfs_tm_UnknownHandler passing on to: $original [::linsert $args 0 $name]" + uplevel 1 $original [::linsert $args 0 $name] + } + } + proc zipfs_tclPkgUnknown {name args} { + #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" + + variable epoch + set pkg_epoch [dict get $epoch pkg current] + + + #global auto_path env + global auto_path + + if {![info exists auto_path]} { + return + } + + set tid [format %-19s -] + catch {set tid [thread::id]} + + if {[info commands ::tcl::zipfs::root] ne ""} { + set zipfsroot [tcl::zipfs::root] + set has_zipfs 1 + } else { + set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands + set has_zipfs 0 + } + + + #review - think about this + #typical dict size might be 800 packages - values are versions + #we probably don't need to create/destroy it for each iteration of the wile. + #question is whether some pkgIndex.tcl files may do a package forget? They probably don't/shouldn't(?) Does that matter here anyway? + set before_dict [dict create] + + + # Cache the auto_path, because it may change while we run through the + # first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + + # Make sure we only scan each directory one time. + if {[info exists tclSeenPath($dir)]} { + set use_path [lrange $use_path 0 end-1] + continue + } + set tclSeenPath($dir) 1 + + # Get the pkgIndex.tcl files in subdirectories of auto_path directories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. + + set use_epoch_for_all 1 + if {$use_epoch_for_all || [string match $zipfsroot* $dir]} { + set currentsearchpath $dir + if {[dict exists $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]} { + set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]] + #puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles ( cached ): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" + } else { + dict set epoch pkg epochs $pkg_epoch indexes $currentsearchpath [dict create] + # ################################################################# + set indexpaths [glob -directory $currentsearchpath -join -nocomplain * pkgIndex.tcl] + foreach idxpath $indexpaths { + dict set epoch pkg epochs $pkg_epoch indexes $currentsearchpath $idxpath 1 + } + set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]] + #puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles (UNcached): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" + # ################################################################# + } + if {![llength $indexfiles]} { + continue + } + + set can_skip_sourcing 0 + if {$has_zipfs && [string match $zipfsroot* $dir]} { + #static auto_path dirs + #can avoid scan if added via this path in any epoch + if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { + if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { + #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. + #puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath" + set can_skip_sourcing 1 + } else { + #if this name is in added then we must have done a package forget or it wouldn't come back to package unknown ? + #remove it and let it be readded if it's still provided by this path? + #probably doesn't make sense for static path? + #dict unset epoch pkg epochs $pkg_epoch added $currentsearchpath $name + } + } + } else { + #dynamic auto_path dirs - libs could have been added/removed + #scan unless cached negative for this epoch + if {[dict exists $epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_sourcing 1 + } + } + #An edge case exception is that after a package forget, a deliberate call to 'package require non-existant' + #will not trigger rescans for all versions of other packages. + #A rescan of a specific package for all versions can still be triggered with a package require for + #an exact non-existant version. e.g package require md5 0-0 + #(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range) + + set sourced 0 + if {!$can_skip_sourcing} { + #Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version. + #this will stop us rescanning everything properly by doing a 'package require nonexistant' + + #use 'info exists' to only call package names once and then append? worth it? + if {![info exists before_pkgs]} { + set before_pkgs [package names] + } + #update the before_dict which persists across while loop + foreach bp $before_pkgs { + dict set before_dict $bp [package versions $bp] + } + catch { + foreach file $indexfiles { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + #puts stderr "----->0 sourcing $file" + incr sourced ;#count as sourced even if source fails; keep before actual source action + #::tcl::Pkg::source $file + tcl_Pkg_source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + } + set dir [lindex $use_path end] + if {![info exists procdDirs($dir)]} { + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file exists", + if {([interp issafe] || [file exists $file])} { + try { + #puts "----->2 sourcing $file" + incr sourced + #::tcl::Pkg::source $file + tcl_Pkg_source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + #dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create] + + #avoid calculating package and version diffs if nothing was actually sourced + if {$sourced > 0} { + if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create] + #ensure there is an empty entry for the path if no packages added or changed versions + } + + set after_pkgs [package names] + set just_added [dict create] + if {[llength $after_pkgs] > [llength $before_pkgs]} { + foreach a $after_pkgs { + if {![dict exists $before_dict $a]} { + dict set just_added $a 1 + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $pkg_epoch + } + } + #puts stderr ">>>zipfs_tclPkgUnknown added [llength $added_pkgs]" + #puts stderr ">>> [join [lrange $added_pkgs 0 10] \n]..." + } + dict for {bp bpversions} $before_dict { + if {[dict exists $just_added $bp]} { + continue + } + if {[llength $bpversions] != [llength [package versions $bp]]} { + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $pkg_epoch + } + } + #puts stderr "zipfs_tclPkgUnknown $tid sourced: $sourced (under path: $currentsearchpath)" + if {$name ni $after_pkgs} { + #cache negative result (for this epoch only) + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } elseif {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + + lappend before_pkgs {*}[dict keys $just_added] + } + } + + } else { + #normal processing - not a static filesystem - we can't skip. + set indexfiles [glob -directory $dir -join -nocomplain * pkgIndex.tcl] + catch { + foreach file $indexfiles { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + #puts "----->1 sourcing $file" + ::tcl::Pkg::source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + } + + set dir [lindex $use_path end] + if {![info exists procdDirs($dir)]} { + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file exists", + if {([interp issafe] || [file exists $file])} { + try { + #puts "----->2 sourcing $file" + ::tcl::Pkg::source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + + } + + + set use_path [lrange $use_path 0 end-1] + + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. + set index 0 + if {[llength $old_path] == [llength $auto_path]} { + foreach dir $auto_path old $old_path { + if {$dir ne $old} { + # This entry in $::auto_path has changed. + break + } + incr index + } + } + + # $index now points to the first element of $auto_path that has + # changed, or the beginning if $auto_path has changed length Scan the + # new elements of $auto_path for directories to add to $use_path. + # Don't add directories we've already seen, or ones already on the + # $use_path. + foreach dir [lrange $auto_path $index end] { + if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { + lappend use_path $dir + } + } + set old_path $auto_path + } + #puts "zipfs_tclPkgUnknown DONE" + } + proc epoch_incr_pkg {args} { + if {[catch { + global auto_path + upvar ::punk::libunknown::epoch epoch + set prev_e [dict get $epoch pkg current] + set current_e [expr {$prev_e + 1}] + dict set epoch pkg current $current_e + dict set epoch pkg epochs $current_e [dict create] + if {[dict exists $epoch pkg epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + set zroot [zipfs root] + dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] { + if {[string match $zroot* $searchpath]} { + set stillvalid 0 + foreach a $auto_path { + if {[string match $a* $searchpath]} { + set stillvalid 1 + break + } + } + if {$stillvalid} { + dict set epoch pkg epochs $current_e indexes $searchpath $indexfiles + } + } + } + } + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e indexes]] + set index_count 0 + dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] { + #update prev epoch to be basic statistical info only + incr index_count [llength $indexfiles] + } + dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count] + dict unset epoch pkg epochs $prev_e indexes + } else { + dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0] + } + if {[dict exists $epoch pkg epochs $prev_e added]} { + #bring across - each lib will have previous epoch number + dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added] + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e added]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e added] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch pkg epochs $prev_e added + } else { + dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0] + } + if {[dict exists $epoch pkg epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch pkg epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch pkg epochs $prev_e unfound + } + } errM]} { + puts stderr "epoch_incr_pkg error\n $errM" + } + } + proc epoch_incr_tm {args} { + if {[catch { + upvar ::punk::libunknown::epoch epoch + set prev_e [dict get $epoch tm current] + set current_e [expr {$prev_e + 1}] + dict set epoch tm current $current_e + dict set epoch tm epochs $current_e [dict create] + set tmlist [tcl::tm::list] + if {[dict exists $epoch tm epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + set zroot [zipfs root] + dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] { + if {[string match $zroot* $searchpath]} { + #check all valid for current state of tcl::tm::list + set stillvalid 0 + foreach tm_path $tmlist { + if {[string match $tm_path* $searchpath]} { + set stillvalid 1 + break + } + } + if {$stillvalid} { + dict set epoch tm epochs $current_e indexes $searchpath $indexfiles + } + } + } + } + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e indexes]] + set index_count 0 + dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] { + #update prev epoch to be basic statistical info only + incr index_count [llength $indexfiles] + } + dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count] + dict unset epoch tm epochs $prev_e indexes + } else { + dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0] + } + if {[dict exists $epoch tm epochs $prev_e added]} { + #bring across - each lib will have previous epoch number + dict set epoch tm epochs $current_e added [dict get $epoch tm epochs $prev_e added] + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e added]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e added] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch tm epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch tm epochs $prev_e added + } else { + dict set epoch tm epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0] + } + if {[dict exists $epoch tm epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch tm epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch tm epochs $prev_e unfound + } + + } errM]} { + puts stderr "epoch_incr_tm error\n $errM" + } + } + + proc init {} { + if {[catch {tcl::tm::list} tmlist]} { + set tmlist [list] + } + set apath [list] + if {[info commands tcl::tm::list] ne ""} { + set tmlist [tcl::tm::list] + } + if {[info exists ::auto_path]} { + set apath $::auto_path + } + if {![llength $tmlist] && ![llength $apath]} { + #shouldn't happen - be noisy about it for now + puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path" + } + + if {[namespace origin ::package] eq "::punk::libunknown::package"} { + #This is far from conclusive - there may be other renamers (e.g commandstack) + return + } + if {[info commands ::punk::libunknown::package] ne ""} { + puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]" + return + } + + trace add variable ::auto_path write ::punk::libunknown::epoch_incr_pkg + trace add variable ::tcl::tm::paths write ::punk::libunknown::epoch_incr_tm + #set stackrecord [commandstack::rename_command -renamer punk::libunknown package {args} { + # #::package override installed by punk::libunknown::init + #} + proc package args { + switch -- [lindex $args 0] { + fo - for - forge - forget { + variable has_package_files + #experimental - silently disallow forgetting things that didn't involve sourcing files + #What about static libs that also sourced files? + #packages loaded by c extensions? + #forgetting Tcl or tcl seems to be a bad idea - package require doesn't work afterwards (independent of this pkg) + set forgets_requested [lrange $args 1 end] + set ok_forgets [list] + foreach p $forgets_requested { + #'package files' not avail in early 8.6 + #There can be other custom 'package ifneeded' scripts that don't use source - but still need to be forgotten. + #a basic/trivial case: 'package ifneeded aaa 0.1.1 {package provide aaa 0.1.1}' + #it could also use 'eval' instead of sourcing. + #For this reason - we shouldn't use 'package files' as any sort of indication of forgetability + #if {$p ni {tcl Tcl} && (!$has_package_files || [package provide $p] eq "" || ($has_package_files && [package provide $p] ne "" && [llength [package files $p]] > 0))} { + # lappend ok_forgets $p + #} + #What then? Hardcoded only for now? + if {$p ni {tcl Tcl tcl::oo}} { + #tcl::oo returns a comment only for its package provide script "# Already present, OK?" + # - so we can't use empty 'ifneeded' script as a determinant. + set vpresent [package provide $p] + if {$vpresent ne ""} { + #There could theoretically be other ifneeded scripts registered - but if the one in use is empty + #we'll use that as the criteria to disallow forget - REVIEW + set ifneededscript [package ifneeded $p $vpresent] + if {[string trim $ifneededscript] ne ""} { + lappend ok_forgets $p + } + } else { + #not loaded - but may have registered ifneeded script(s) in the package database + #assume ok to forget + lappend ok_forgets $p + } + } + } + if {[llength $ok_forgets]} { + return [::package:: forget {*}$ok_forgets] + } else { + return + } + } + ep - epo - epoc - epoch { + upvar ::punk::libunknown::epoch epoch + set epoch_args [lrange $args 1 end] + switch -- [llength $epoch_args] { + 0 { + set tm_epoch [dict get $epoch tm current] + set pkg_epoch [dict get $epoch pkg current] + return [dict create tm $tm_epoch pkg $pkg_epoch] + } + 1 { + switch -- [lindex $epoch_args 0] { + tm { + set cur [dict get $epoch tm current] + return [dict create $cur [dict get $epoch tm epochs $cur]] + } + pkg { + set cur [dict get $epoch pkg current] + return [dict create $cur [dict get $epoch pkg epochs $cur]] + } + incr { + epoch_incr_pkg + epoch_incr_tm + } + default { + error "package epoch [lindex $epoch_args 0] unsupported - known options: tm pkg incr" + } + } + } + 2 { + set a2 [list [lindex $epoch_args 0] [lindex $epoch_args 1]] + switch -- $a2 { + {pkg incr} - {incr pkg} { + epoch_incr_pkg + } + {tm incr} - {incr tm} { + epoch_incr_tm + } + default { + set which [lindex $epoch_args 0] + set index [lindex $epoch_args 1] + if {$which in {pkg tm}} { + set epochs [dict keys [dict get $epoch $which epochs]] + if {[catch { + set epochinfo [dict get $epoch $which epochs $index] + } errM]} { + error "package epoch $which unable to use index $index" + } + return $epochinfo + } else { + error "package epoch {*}$a2 unsupported - expected 'pkg incr' or 'tm incr' or 'pkg ' or 'tm '" + } + } + } + } + default { + set which [lindex $epoch_args 0] + set index [lindex $epoch_args 1] + set keys [lrange $epoch_args 2 end] + if {$which in {pkg tm}} { + set epochs [dict keys [dict get $epoch $which epochs]] + if {[catch { + set epochinfo [dict get $epoch $which epochs $index] + } errM]} { + error "package epoch $which unable to use index $index" + } + if {![dict exists $epochinfo {*}$keys]} { + set topkeys [dict keys $epochinfo] + error "package epoch $which $index $keys not found. Toplevel keys: $topkeys" + } + return [dict get $epochinfo {*}$keys] + } else { + error "package epoch unimplemented" + } + } + } + } + default { + return [::package:: {*}$args] + } + } + } + rename ::package ::package:: + #all lowercase procs already exported from ::punk::libunknown + namespace eval :: [list ::namespace import ::punk::libunknown::package] + + #if {[info commands ::tcl::zipfs::root] ne ""} { + # set has_zipfs_tm 0 + # foreach t $tmlist { + # if {[string match [::tcl::zipfs::root]* $t]} { + # set has_zipfs_tm 1 + # break ;#zipfs_tm_UnknownHandler can handle either - a single zipfs path is enough + # } + # } + # set has_zipfs_auto 0 + # foreach a $apath { + # if {[string match [::tcl::zipfs::root]* $a]} { + # set has_zipfs_auto 1 + # break + # } + # } + # if {$has_zipfs_tm || $has_zipfs_auto} { + # if {$has_zipfs_tm && $has_zipfs_auto} { + # package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + # } elseif {$has_zipfs_tm} { + # package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::tclPkgUnknown} + # } else { + # #must only have auto + # #puts "tmlist : $tmlist" + # #puts "autopath: $apath" + # package unknown {::tcl::tm::UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + # } + # } + # #review - tm and auto_path entries for safebase interps are obscured. For now we will ignore and defaults will apply. + # #to load in safebase anyway - module would probably have to be passed to interp as source to eval? + #} + + if {![interp issafe]} { + package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + } + + } + + proc default {} { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::libunknown ---}] +} +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::libunknown +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::libunknown [tcl::namespace::eval punk::libunknown { + variable pkg punk::libunknown + variable version + set version 0.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm index fa9e8d7c..7377929a 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc { cd $original_wd } proc validate {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::mix::commandset::doc::validate - -- -type none -optional 1 -help "end of options marker --" + -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 - } $args] + }] set opt_individual [tcl::dict::get $argd opts -individual] set patterns [tcl::dict::get $argd values patterns] - + #todo - run and validate punk::docgen output set projectdir [punk::repo::find_project] if {$projectdir eq ""} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm index 05e94a25..47e37909 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout { return [join $layouts \n] } + punk::args::define { + @id -id ::punk::mix::commandset::layout::collection::_default + @cmd -name ::punk::mix::commandset::layout::collection::_default + -startdir -type string + -not -type string -multiple 1 + globsearches -default * -multiple 1 + } proc _default {args} { - punk::args::get_dict [subst { - @id -id ::punk::mix::commandset::layout::collection::_default - @cmd -name ::punk::mix::commandset::layout::collection::_default - -startdir -type string - -not -type string -multiple 1 - globsearches -default * -multiple 1 - }] $args + punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default + set tdict_low_to_high [as_dict {*}$args] #convert to screen order - with higher priority at the top diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 98f171c7..8ef36e27 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap { namespace eval lib { #*** !doctools #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] - #[para] Library API functions for punk::mix::commandset::scriptwrap + #[para] Library API functions for punk::mix::commandset::scriptwrap #[list_begin definitions] - + punk::args::define { + @id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders + #*** !doctools + #[call [fun get_wrapper_folders] [arg args] ] + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo + #[para] Arguments: + # [list_begin arguments] + # [arg_def string args] name-value pairs -scriptpath + # [list_end] + @cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\ + "Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo" + @opts -anyopts 0 + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + @values -minvalues 0 -maxvalues 0 + } proc get_wrapper_folders {args} { - set argd [punk::args::get_dict { - #*** !doctools - #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo - #[para] Arguments: - # [list_begin arguments] - # [arg_def string args] name-value pairs -scriptpath - # [list_end] - @id -id ::punk::mix::commandset::scriptwrap - @cmd -name punk::mix::commandset::get_wrapper_folders - - @opts -anyopts 0 - -scriptpath -default "" -type directory\ - -help "" - #todo -help folder within a punk.templates provided area??? - - @values -minvalues 0 -maxvalues 0 - } $args] + set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders] # -- --- --- --- --- --- --- --- --- set opt_scriptpath [dict get $argd opts -scriptpath] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index bce44dee..f018486d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs { # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied + punk::args::define { + @id -id ::punk::nav::fs::dirfiles_dict + @cmd -name punk::nav::fs::dirfiles_dict + @opts -any 0 + -searchbase -default "" + -tailglob -default "\uFFFF" + #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) + -with_sizes -default "\uFFFF" -type string + -with_times -default "\uFFFF" -type string + @values -min 0 -max -1 -type string + } proc dirfiles_dict {args} { - set argspecs { - @id -id ::punk::nav::fs::dirfiles_dict - @opts -any 0 - -searchbase -default "" - -tailglob -default "\uFFFF" - #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string - -with_times -default "\uFFFF" -type string - @values -min 0 -max -1 -type string - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict] lassign [dict values $argd] leaders opts vals set searchspecs [dict values $vals] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index b89bc021..b8ad757f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -21,7 +21,7 @@ package require punk::lib package require punk::args tcl::namespace::eval ::punk::ns::evaluator { - #eval-_NS_xxx_NS_etc procs + #eval-_NS_xxx_NS_etc procs } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -33,7 +33,7 @@ tcl::namespace::eval punk::ns { } variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns - namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp + namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype resolve_command synopsis namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc catch { @@ -43,7 +43,7 @@ tcl::namespace::eval punk::ns { #debug level punk.ns.compile 3 } - #leading colon makes it hard (impossible?) to call directly if not within the namespace + #leading colon makes it hard (impossible?) to call directly if not within the namespace proc ns/ {v {ns_or_glob ""} args} { variable ns_current ;#change active ns of repl by setting ns_current @@ -67,7 +67,7 @@ tcl::namespace::eval punk::ns { if {$ns_or_glob eq ""} { set is_absolute 1 set ns_queried $ns_current - set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] set has_globchars [regexp {[*?]} $ns_or_glob] @@ -78,10 +78,10 @@ tcl::namespace::eval punk::ns { } set ns_current $ns_or_glob set ns_queried $ns_current - tailcall ns/ $v "" + tailcall ns/ $v "" } else { set ns_queried $ns_or_glob - set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] } } else { if {!$has_globchars} { @@ -91,10 +91,10 @@ tcl::namespace::eval punk::ns { } set ns_current $nsnext set ns_queried $nsnext - set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] } else { set ns_queried [nsjoin $ns_current $ns_or_glob] - set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] } } } @@ -103,7 +103,7 @@ tcl::namespace::eval punk::ns { if {$ns_current in [info commands $ns_current] } { if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { if {[llength $ensemble_info] > 0} { - #this namespace happens to match ensemble command. + #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" } @@ -158,7 +158,7 @@ tcl::namespace::eval punk::ns { } else { set out [get_nslist -match [nsjoin $nsq *] -types [list all]] } - #set out [nslist [nsjoin $nsq *]] + #set out [nslist [nsjoin $nsq *]] set ns_current $nsq append out "\n$ns_current" return $out @@ -252,8 +252,15 @@ tcl::namespace::eval punk::ns { } else { set nsfq $ns } - set ns_script [nseval_ifexists_getscript $nsfq] - uplevel 1 [list {*}$ns_script $script] + if {[lsearch [nsparts $nsfq] :*] >=0} { + #weird_ns + set ns_script [nseval_ifexists_getscript $nsfq] + return [uplevel 1 [list {*}$ns_script $script]] + } else { + if {[namespace exists $nsfq]} { + return [namespace eval $nsfq $script] + } + } } proc nseval_ifexists_getscript {location} { set parts [nsparts $location] @@ -323,7 +330,7 @@ tcl::namespace::eval punk::ns { } #Note nsjoin,nsjoinall,nsprefix,nstail are string functions that don't care about namespaces in existence. - #Some functions in punk::ns are + #Some functions in punk::ns are proc nsjoin {prefix name} { if {[string match ::* $name]} { @@ -422,19 +429,19 @@ tcl::namespace::eval punk::ns { #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y - #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them + #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) - #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string + #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' - #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah - # is this :: punk :etc :blah or :: punk :etc: blah - #clearly leading/trailing colons in namespaces and commands are just a bad idea. + #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah + # is this :: punk :etc :blah or :: punk :etc: blah + #clearly leading/trailing colons in namespaces and commands are just a bad idea. #nsparts will prefer leading colon (ie greedy on ::) #This is important to support leading colon commands such as :/ # ie ::punk:::jjj:::etc -> :: punk :jjj :etc proc nsparts {nspath} { set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] if {[lindex $parts end] eq ""} { @@ -526,7 +533,7 @@ tcl::namespace::eval punk::ns { proc nstree {{location ""}} { if {![string match ::* $location]} { set nscaller [uplevel 1 {::namespace current}] - set location [nsjoin $nscaller $location] + set location [nsjoin $nscaller $location] } list_as_lines [nstree_list $location] } @@ -548,18 +555,18 @@ tcl::namespace::eval punk::ns { set subnslist [dict get $opts -subnslist] set allbelow [dict get $opts -allbelow] ;#whether to return matches longer than the matched glob-path # -- ---- --- --- --- --- - + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $location]] set has_globchars [regexp {[*?]} $ns_absolute] ;#don't use regexes on plain namespaces with no glob chars if {!$has_globchars && !$allbelow && ![llength $subnslist]} { - #short circuit trivial case + #short circuit trivial case return [list $location] } - - set base "" + + set base "" set tailparts [list] - if {$CALLDEPTH == 0} { + if {$CALLDEPTH == 0} { set parts [nsparts $ns_absolute] lset parts 0 :: set idx 0 @@ -577,12 +584,12 @@ tcl::namespace::eval punk::ns { set base $ns_absolute } } else { - set base $location + set base $location set tailparts $subnslist } if {![tcl::namespace::exists $base]} { return [list] - } + } #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] @@ -592,19 +599,19 @@ tcl::namespace::eval punk::ns { #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" - #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx + #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx if {[llength $tailparts]} { set nextglob [lindex $tailparts 0] if {$nextglob eq "**"} { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } elseif {[regexp {[*]{2}$} $nextglob]} { set nslist [list] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] foreach ch $nsmatches { lappend nslist $ch - #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] - lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] - } + #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] + } } else { #lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) set nslist [list] @@ -612,7 +619,7 @@ tcl::namespace::eval punk::ns { if {[llength $tailparts] >1 || $allbelow} { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { #if only one tailpart remaining and not $allbelow - then we already have what we need @@ -626,13 +633,13 @@ tcl::namespace::eval punk::ns { set nslist [list] foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] } } else { set nslist $allchildren } #set nsmatches $allchildren - #set nslist [nstree_list $base -subnslist {} -allbelow 0] + #set nslist [nstree_list $base -subnslist {} -allbelow 0] } set nslist [lsort -unique $nslist] @@ -652,10 +659,10 @@ tcl::namespace::eval punk::ns { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } } @@ -670,14 +677,14 @@ tcl::namespace::eval punk::ns { if {$base ni $nslist} { #puts stderr "> adding $base to $nslist" set nslist [list $base {*}$nslist] - } + } if {$has_globchars} { if {$allbelow} { foreach ns $nslist { if {[globmatchns ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { set nslist_filtered [struct::list::Lfilter $nslist [list globmatchns ${ns_absolute}]] } @@ -687,7 +694,7 @@ tcl::namespace::eval punk::ns { if {[string equal ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { #set nslist_filtered [struct::list::Lfilter $nslist [list string match ${ns_absolute}]] set nslist_filtered [list $ns_absolute] @@ -705,9 +712,54 @@ tcl::namespace::eval punk::ns { if {$ansicodes eq ""} { return $usageinfo_char } elseif {$ansicodes eq "\UFFEF"} { - return " [a+ brightyellow]$usageinfo_char[a]" + return "[a+ brightyellow]$usageinfo_char[a]" + } else { + return "[a+ {*}$ansicodes]$usageinfo_char[a]" + } + } + + punk::args::define { + @id -id ::punk::ns::Cmark + @cmd -name punk::ns::Cmark + @leaders + type -choices {oo ooc ooo punkargs ensemble native} -choicelabels { + oo " symbol \u25c6" + ooc " symbol \u25c7" + ooo " symbol \u25c8" + punkargs " symbol \U1f6c8" + ensemble " symbol \u24ba" + native " symbol \u24c3" + unknown " symbol \u2370" + } + @opts + @values -min 0 -max -1 + ansiname -type string -optional 1 -multiple 1 -help\ + "ansi names as accepted by punk::ansi::a+ + e.g + red bold + (Not raw ansi codes)" + } + proc Cmark {args} { + if {[llength $args] == 0} { + punk::args::parse {} withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + set type [lindex $args 0] + set type [tcl::prefix::match -error "" {oo ooc ooo punkargs ensemble native unknown} $type] + set ansinames [lrange $args 1 end] + switch -- $type { + oo - ooc - ooo - punkargs - ensemble - native - unknown {} + default { + #punk::args::usage ::punk::ns::Cmark + punk::args::parse $args withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + } + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + if {[llength $ansinames]} { + return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]" } else { - return " [a+ {*}$ansicodes]$usageinfo_char[a]" + return [dict get $marks $type] } } @@ -720,7 +772,7 @@ tcl::namespace::eval punk::ns { -nsdict ""\ ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- set fq_glob [dict get $opts -match] set requested_types [dict get $opts -types] set opt_nsdict [dict get $opts -nsdict] @@ -749,7 +801,7 @@ tcl::namespace::eval punk::ns { } foreach t $types { switch -- $t { - oo - all - + oo - all - children - commands - exported - imported - aliases - procs - ensembles - ooclasses - ooobjects - ooprivateobjects - ooprivateclasses - native - coroutines - interps - zlibstreams {} default { error "Unrecognised namespace member type: $t known types: $known_types oo all" @@ -783,19 +835,19 @@ tcl::namespace::eval punk::ns { set usageinfo [list] if {$opt_nsdict eq ""} { - set nsmatches [get_ns_dicts $fq_glob -allbelow 0] + set nsmatches [get_ns_dicts $fq_glob -allbelow 0] set itemcount 0 set matches_with_results [list] foreach nsinfo $nsmatches { - set itemcount [dict get $nsinfo itemcount] + set itemcount [dict get $nsinfo itemcount] if {$itemcount > 0} { lappend matches_with_results $nsinfo - } + } } if {[llength $matches_with_results] == 1} { set contents [lindex $matches_with_results 0] } elseif {[llength $matches_with_results] > 1} { - puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" + puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" set contents [lindex $matches_with_results 0] } else { return "- no results -" @@ -806,7 +858,7 @@ tcl::namespace::eval punk::ns { return "- no results -" } } - set ns [dict get $contents location] + set ns [dict get $contents location] package require overtype if {"children" in $types} { @@ -871,19 +923,19 @@ tcl::namespace::eval punk::ns { } #elements are commands and possibly renamed aliases which may or may not have been renamed into the current namespace - #a command could be an empty string or something else weird. + #a command could be an empty string or something else weird. #Primarily just to handle empty string command - we will wrap each command as a 2-part element here #(our foreach loop needs to ignore missing commands - but not empty string) set elements [lmap v $commands {list c $v}] set seencmds [list] - set masked [list] ;# + set masked [list] ;# #jmn #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { - #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo + #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo #we can detect masking by proc/ensemble/oo - but not by a binary extension loaded after the rename: REVIEW if {$a in $cmdsets} { #we have an alias that is also a known other command-type @@ -896,15 +948,15 @@ tcl::namespace::eval punk::ns { } } set elements [lsort -index 1 $elements] - - + + set numelements [llength $elements] if {$numelements} { set split1 [expr {int(ceil($numelements/4.0))}] set elements1 [lrange $elements 0 $split1-1] set remaining3 [lrange $elements $split1 end] - set numremaining3 [llength $remaining3] + set numremaining3 [llength $remaining3] set split2 [expr {int(ceil($numremaining3/3.0))}] set elements2 [lrange $remaining3 0 $split2-1] set remaining2 [lrange $remaining3 $split2 end] @@ -1019,12 +1071,12 @@ tcl::namespace::eval punk::ns { } } if {$cmd in $usageinfo} { - set u [Usageinfo_mark brightgreen] + set u " [Cmark punkargs brightgreen]" } else { set u "" } set cmd$i "${prefix} $c$cmd_display$u" - #set c$i $c + #set c$i $c set c$i "" lappend seencmds $cmd } @@ -1033,7 +1085,7 @@ tcl::namespace::eval punk::ns { #lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] lappend displaylist $a1[overtype::left $col1 $ch1][a]$a1[overtype::left $col2 $ch2][a]$c1[overtype::left $col3 $cmd1][a]$c2[overtype::left $col4 $cmd2][a]$c3[overtype::left $col5 $cmd3][a]$c4$cmd4[a] } - + return [list_as_lines $displaylist] } proc nspath_here_absolute {{nspath "\uFFFF"}} { @@ -1060,12 +1112,13 @@ tcl::namespace::eval punk::ns { return [nsjoin $base $nspath] } + variable has_textblock set has_textblock [expr {![catch {package require textblock}]}] if {$has_textblock} { interp alias "" ::punk::ns::Block_width "" textblock::width - } else { - #maint - equiv of textblock::width + } else { + #maint - equiv of textblock::width proc Block_width {textblock} { if {$textblock eq ""} { return 0 } if {[tcl::string::last \t $textblock] >=0} { @@ -1085,38 +1138,55 @@ tcl::namespace::eval punk::ns { return [punk::char::ansifreestring_width $textblock] } } - proc nslist {{glob "*"} args} { - set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] - if {[dict exists $args -match]} { - #review - presumably this is due to get_nslist taking -match? - error "nslist requires positional argument 'glob' instead of -match option" - } - set defaults [dict create\ - -match $ns_absolute\ - -nspathcommands 0\ - ] - set opts [dict merge $defaults $args] + punk::args::define { + @id -id ::punk::ns::nslist + @cmd -name punk::ns::nslist -help\ + "Return a textual representation of + the child namespaces and commands within + the namespace(s) matched by glob." + @opts + -nspathcommands -type boolean -default 0 + -types + @values -min 0 -max -1 + glob -multiple 1 -optional 1 -default "*" + } + proc nslist {args} { + set argd [punk::args::parse $args withid ::punk::ns::nslist] + lassign [dict values $argd] leaders opts values received solos multis + + #if {[dict exists $args -match]} { + # #review - presumably this is due to get_nslist taking -match? + # error "nslist requires positional argument 'glob' instead of -match option" + #} + #set defaults [dict create\ + # -match $ns_absolute\ + # -nspathcommands 0\ + #] + #set opts [dict merge $defaults $args] # -- --- --- set opt_nspathcommands [dict get $opts -nspathcommands] # -- --- --- - - - set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + set globlist [dict get $values glob] set with_results [list] - foreach nsdict $ns_matches { - if {[dict get $nsdict itemcount]>0} { - lappend with_results $nsdict + foreach glob $globlist { + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] + set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + foreach nsdict $ns_matches { + if {[dict get $nsdict itemcount]>0} { + lappend with_results $nsdict + } } } - #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' + #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' set count_with_results [llength $with_results] set output "" + variable has_textblock foreach nsdict $with_results { - dict set opts -nsdict $nsdict - set block [get_nslist {*}$opts] + set loc [dict get $nsdict location] + set block [get_nslist -nsdict $nsdict -match ${loc}::* {*}$opts] #if {[string first \n $block] < 0} { # #single line # set width [Block_width [list $block]] @@ -1125,7 +1195,7 @@ tcl::namespace::eval punk::ns { #} set width [Block_width $block] - #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location + #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location if {$count_with_results > 1 || [regexp {[*?]} [nsprefix $ns_absolute]]} { append output \n [dict get $nsdict location] } @@ -1139,17 +1209,24 @@ tcl::namespace::eval punk::ns { } else { append path_text \n " also resolving cmds in namespace paths:" set nspathdict [dict get $nsdict namespacepath] - dict for {k v} $nspathdict { - set cmds [dict get $v commands] - append path_text \n " path: $k" - append path_text \n " cmds: $cmds" + if {!$has_textblock} { + dict for {k v} $nspathdict { + set cmds [dict get $v commands] + append path_text \n " path: $k" + append path_text \n " cmds: $cmds" + } + } else { + dict for {k v} $nspathdict { + set t [textblock::list_as_table -title $k -columns 6 [lsort [dict get $v commands]]] + append path_text \n $t + } } } append output $path_text set path_text_width [Block_width $path_text] - append output \n [string repeat - [expr {max($width,$path_text_width)}]] + append output \n [string repeat - [expr {max($width,$path_text_width)}]] } elseif {$count_with_results > 1 && $width > 0 } { - append output \n [string repeat - $width] + append output \n [string repeat - $width] } } return $output @@ -1160,7 +1237,7 @@ tcl::namespace::eval punk::ns { return [get_ns_dicts $ns_absolute {*}$args] } - #info cmdtype available in 8.7+ + #info cmdtype available in 8.7+ #safe interps also seem to have it disabled for some reason #we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc #IMPORTANT: don't detect easy types such as proc/import here - caller needs the 'na' to do the proper fallback @@ -1227,7 +1304,7 @@ tcl::namespace::eval punk::ns { } #we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller #also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! - return na + return na } #non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob #returns a list of dicts even if only one ns matched @@ -1260,17 +1337,18 @@ tcl::namespace::eval punk::ns { set glob [nstail $fq_glob] set matched_namespaces [nstree_list $nsglob -allbelow $allbelow] - set report_namespaces [list] + set report_namespaces [list] #special case trailing ** in last segment if {[regexp {[*]{2}$} $glob]} { - lappend report_namespaces {*}$matched_namespaces + lappend report_namespaces {*}$matched_namespaces foreach ns $matched_namespaces { lappend report_namespaces {*}[nstree_list [nsjoin $ns $glob]] } } else { - set report_namespaces $matched_namespaces + set report_namespaces $matched_namespaces } - punk::args::update_definitions $report_namespaces + #puts stderr "---->get_ns_dicts '$fq_glob $args' update_definitions $report_namespaces" + punk::args::update_definitions $report_namespaces set nsdict_list [list] foreach ch $report_namespaces { @@ -1280,27 +1358,27 @@ tcl::namespace::eval punk::ns { } else { set allchildren [nschildren $ch] ; #sorted, only returns 1 level deeper } - + #nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string. # By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {} #set commands [.= nscommands -raw [nsjoin $ch $glob] |> punk::lib::linelist -block {}] set commands [punk::lib::linelist -block {} [nscommands -raw [nsjoin $ch $glob]]] - #by convention - returning just \n represents a single result of the empty string whereas no results + #by convention - returning just \n represents a single result of the empty string whereas no results #after passing through linelist this becomes {} {} which appears as a list of two empty strings. - #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines + #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines #unless we always return a newline at the tail if there is a result #For this reason nscommands returns a trailing newline - so the last entry should always be empty string - and is a bogus entry - #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. + #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. if {[lindex $commands end] eq ""} { set commands [lrange $commands 0 end-1] } else { puts stderr "get_ns_dicts WARNING nscommands didn't return a trailing newline - unexpected" } - - + + #JMN - set location $ch + set location $ch set locationparts [nsparts $location] set weird_ns 0 if {[lsearch $locationparts :*] >= 0} { @@ -1309,7 +1387,7 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set exportpatterns [nseval_ifexists $location {::namespace export}] set nspathlist [nseval_ifexists $location {::namespace path}] - } else { + } else { set exportpatterns [tcl::namespace::eval $location {::namespace export}] set nspathlist [tcl::namespace::eval $location {::namespace path}] } @@ -1335,7 +1413,7 @@ tcl::namespace::eval punk::ns { #! info commands can't glob with a weird ns prefix #! info commands with no arguments returns all commands (from global and any other ns in namespace path) #lappend matched {*}[nseval_ifexists $location [list ::info commands [nsjoin ${location} $p]]] - lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { + lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { set allcommands [info commands] set matches [list] foreach c $allcommands { @@ -1360,9 +1438,9 @@ tcl::namespace::eval punk::ns { set allexported [lsort -unique $allexported] #NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace) if {$weird_ns} { - set allprocs [nseval_ifexists $location {::info procs}] + set allprocs [nseval_ifexists $location {::info procs}] } else { - set allprocs [tcl::namespace::eval $location {::info procs}] + set allprocs [tcl::namespace::eval $location {::info procs}] } #set allprocs [nseval $location {::info procs}] set childtails [lmap v $allchildren {nstail $v}] @@ -1382,24 +1460,24 @@ tcl::namespace::eval punk::ns { #use aliases glob - because aliases can be present with or without leading :: #NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases if {$weird_ns} { - set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } else { - set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } - #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] foreach a $raw_aliases { if {[string match *:: $a]} { #exception for alias such as ::p::2:: so that it doesn't show up as empty string #lappend aliases :: #JMN - 2023 - better to display an empty string somehow - lappend aliases "" + lappend aliases "" } else { lappend aliases [nstail $a] } } - #NOTE for 'info ...' 'namespace origin|(etc)..' + #NOTE for 'info ...' 'namespace origin|(etc)..' # - use the pattern [namespace eval $location [list $cmd]] #This allows examination of cmds with "bad" names such as empty string or prefixed with single colon. #while these should be rare - we want to handle such edge cases when browsing namespaces. @@ -1433,7 +1511,7 @@ tcl::namespace::eval punk::ns { } if {$weird_origin} { if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { @@ -1444,7 +1522,7 @@ tcl::namespace::eval punk::ns { } } else { if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { @@ -1454,7 +1532,7 @@ tcl::namespace::eval punk::ns { } } - } + } default { if {$ctype eq "import"} { if {$weird_ns} { @@ -1462,7 +1540,7 @@ tcl::namespace::eval punk::ns { } else { set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] } - #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source + #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source #ie we don't need to follow a chain of 'imported' results. set origin_location [nsprefix $cmdorigin] set origin_cmd [nstail $cmdorigin] @@ -1491,7 +1569,7 @@ tcl::namespace::eval punk::ns { lappend allensembles $cmd } i-alias - alias { - #review + #review lappend allaliases $cmd } i-object - object { @@ -1520,7 +1598,7 @@ tcl::namespace::eval punk::ns { lappend allzlibstreams $cmd } default { - #there may be other registered types + #there may be other registered types #(extensible with Tcl_RegisterCommandTypeName) lappend allothers $cmd } @@ -1535,7 +1613,7 @@ tcl::namespace::eval punk::ns { #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. set nsorigin [namespace origin ${location}::] } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] + set nsorigin [nseval $location "::namespace origin $cmd"] } else { set nsorigin [namespace origin [nsjoin $location $cmd]] } @@ -1585,12 +1663,12 @@ tcl::namespace::eval punk::ns { set imported $allimported set undetermined $allundetermined } - - #itemcount will overcount if we are including commands as well as procs/exported etc - + + #itemcount will overcount if we are including commands as well as procs/exported etc - set itemcount 0 incr itemcount [llength $childtailmatches] incr itemcount [llength $commands] - + #incr itemcount [llength $procs] #incr itemcount [llength $exported] @@ -1606,6 +1684,7 @@ tcl::namespace::eval punk::ns { set has_punkargs [expr {[info commands ::punk::args::id_exists] ne ""}] set has_tepam [expr {[info exists ::tepam::ProcedureList]}] if {$has_punkargs || $has_tepam} { + set ns_updated [dict create] foreach c $commands { if {$c in $imported} { set fq [namespace origin [nsjoin $location $c]] @@ -1613,7 +1692,7 @@ tcl::namespace::eval punk::ns { #TODO - use which_alias ? set tgt [interp alias "" [nsjoin $location $c]] if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] + set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] } set word1 [lindex $tgt 0] if {$word1 eq "punk::mix::base::_cli"} { @@ -1623,7 +1702,11 @@ tcl::namespace::eval punk::ns { } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) - set fq $word1 + if {[string match ::* $word1]} { + set fq $word1 + } else { + set fq ::$word1 + } } } else { set fq [nsjoin $location $c] @@ -1631,7 +1714,12 @@ tcl::namespace::eval punk::ns { if {$has_punkargs} { #set id [string trimleft $fq :] set id $fq - punk::args::update_definitions [list [namespace qualifiers $id]] + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1675,10 +1763,10 @@ tcl::namespace::eval punk::ns { ] lappend nsdict_list $nsdict } - return $nsdict_list + return $nsdict_list } #Must be no ansi when only single arg used. - #review - ansi codes will be very confusing in some scenarios! + #review - ansi codes will be very confusing in some scenarios! #todo - only output color when requested (how?) or via repltelemetry ? interp alias {} nscommands2 {} .= ,'ok'@0.= { #Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x @@ -1688,13 +1776,13 @@ tcl::namespace::eval punk::ns { ::set commandns [::namespace current] ::set commandlist [::list] #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway - #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed + #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed ::set colors [::list none cyan yellow green] ::set ci 0 ;#colourindex ::set do_raw 0 ::if {[::set posn [::lsearch $searchlist -raw]] >= 0} { ::set searchlist [::lreplace $searchlist $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } ::if {![::llength $searchlist]} { ::lappend searchlist * @@ -1714,7 +1802,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1731,7 +1819,7 @@ tcl::namespace::eval punk::ns { ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } if 0 { @@ -1771,19 +1859,19 @@ tcl::namespace::eval punk::ns { ::list ok [::list result $commandlist] #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. - } |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} = 0} { ::set args [::lreplace $args $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } if {![llength $args]} { lappend args * @@ -1801,7 +1889,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1817,7 +1905,7 @@ tcl::namespace::eval punk::ns { set weird_ns 0 if {[string match *:::* $base]} { set weird_ns 1 - } + } #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created if {$weird_ns} { ::if {![nsexists $base]} { @@ -1838,7 +1926,7 @@ tcl::namespace::eval punk::ns { }} $base $what ]] } else { ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] } @@ -1903,7 +1991,7 @@ tcl::namespace::eval punk::ns { info commands ${input} } } - } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + } errM]} { + puts stderr "$errM" + set origin $querycommand + set resolved $querycommand + } + } else { + #fully qualified command specified but doesn't exist + set origin $querycommand + set resolved $querycommand + } + } else { + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand + } else { + #set thispath [uplevel 1 [list ::nsthis $querycommand]] + set thispath [uplevel 1 [list ::punk::ns::nspath_here_absolute $querycommand]] + set targetns [nsprefix $thispath] + set name [nstail $thispath] + set targetparts [nsparts $targetns] + if {[lsearch $targetparts :*] >=0} { + #weird ns + set valid_ns [nsexists $targetns] + } else { + set valid_ns [namespace exists $targetns] + } + if {$valid_ns} { + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + }]} { + set thiscmd [nsjoin $targetns $name] + #relative querycommand specified - but Tcl didn't find a match in namespace path + #assume global (todo - look for namespace match in auto_index first ?) + set origin ::$name + set resolved ::$name + } + } else { + #namespace as relative to current doesn't seem to exist + #Tcl would also attempt to resolve as global + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::resolve_command $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand + + } + } + } + #ns::cmdtype only detects alias type on 8.7+? + set initial_cmdtype [punk::ns::cmdtype $origin] + switch -- $initial_cmdtype { + na - alias { + #REVIEW - alias entry doesn't necessarily match command! + #consider using which_alias (wiki) + set tgt [interp alias "" $origin] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft $origin :]] + } + #first word of tgt may be namespace relative or absolute + if {$tgt ne ""} { + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set targetword [lindex $tgt end] + } else { + #todo - alias may have prefilled some leading args - so usage report should reflect that??? + #(possible curried arguments) + #review - curried arguments could be for ensembles! + set targetword $word1 + return [namespace eval :: [list punk::ns::resolve_command $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + } + + + set origin $targetword + #retest cmdtype on modified origin + set cmdtype [punk::ns::cmdtype $origin] + } else { + set cmdtype $initial_cmdtype + } + if {$cmdtype eq "na"} { + #tcl 8.6 + if {[info object isa object $origin]} { + set cmdtype "object" + } + } + } + default { + set cmdtype $initial_cmdtype + } + } + + punk::args::update_definitions [list [namespace qualifiers $origin]] + set id $origin + + + #don't shortcircuit if no args id - need to allow (autodef) even for argumentless query e.g resolve_command dict + if {[punk::args::id_exists $id] && ![llength $queryargs]} { + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + #puts "--->resolve_command '$args' update_definitions [list [namespace qualifiers $origin]]" + if {![punk::args::id_exists $origin]} { + if {[namespace ensemble exists $origin]} { + #review + #todo - check -unknown + #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + #presumably -choiceprefix should be zero in that case?? + + set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] + + #review - we can have a combination of commands from -map as well as those exported from -namespace + # if and only if -subcommands is specified + + set subcommand_dict [dict create] + set commands [list] + set nscommands [list] + if {[llength [dict get $ensembleinfo -subcommands]]} { + #set exportspecs [namespace eval $ns {namespace export}] + #foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + #} + #when using -subcommands, even unexported commands are available + set nscommands [info commands ${ns}::*] + foreach sub [dict get $ensembleinfo -subcommands] { + if {[dict exists $map $sub]} { + #-map takes precence over same name exported from -namespace + dict set subcommand_dict $sub [dict get $map $sub] + } elseif {"${ns}::$sub" in $nscommands} { + dict set subcommand_dict $sub ${ns}::$sub + } else { + #subcommand probably supplied via -unknown handler? + dict set subcommand_dict $sub "" + } + } + } else { + if {[dict size $map]} { + set subcommand_dict $map + } else { + set exportspecs [namespace eval $ns {namespace export}] + foreach pat $exportspecs { + lappend nscommands {*}[info commands ${ns}::$pat] + } + foreach fqc $nscommands { + dict set subcommand_dict [namespace tail $fqc] $fqc + } + } + } + + + set subcommands [lsort [dict keys $subcommand_dict]] + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs + } + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + #must be exact match - not a prefix + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set resolve_next [list {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + puts "+++> resolve_next: $resolve_next" + + set sub_resolution [resolve_command {*}$resolve_next] + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + + #set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match] + + puts stderr "+++> $sub_resolution" + puts stderr "+++> $f" + dict set sub_resolution args_full $f + return $sub_resolution + } + } + + set choiceinfodict [dict create] + set choicelabeldict [dict create] + + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + dict set choiceinfodict $sub [list [list resolved $subwhat]] + + if {$targettail in [dict get $nsinfo usageinfo]} { + dict lappend choiceinfodict $sub {doctype punkargs} + #dict set choicelabeldict $sub [punk::ns::synopsis $subwhat] + } + if {$targettail in [dict get $nsinfo ensembles]} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + if {$targettail in [dict get $nsinfo ooobjects]} { + if {$targettail in [dict get $nsinfo ooclasses]} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$targettail in [dict get $nsinfo native]} { + dict lappend choiceinfodict $sub {doctype native} + } + } + + + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + set argdef [punk::lib::tstr -return string { + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + Ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -ensembleparameter 1 -help {leading ensemble parameter - passed to subcommand}" + } + } + append argdef \n $vline + punk::args::define $argdef + set id $autoid + } + } + #testing where id = $origin or id = (autodef)::$origin + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set specid $id + set specargs $queryargs + if {[llength $queryargs]} { + #JJJ + set spec [punk::args::get_spec $id] + #TODO -form + set form_names [dict get $spec form_names] + + #'subcommands' only allowed in single-form commands - review + set fid [lindex $form_names 0] + + set leadernames [dict get $spec FORMS $fid LEADER_NAMES] + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + #'subcommands' are only present in forms that consist solely of leaders - REVIEW + #(does not have to dispatch on 1st leader - e.g consider ensemble -parameters) + if {[llength $form_names] == 1 && ![llength $optnames] && ![llength $valnames]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + + set leadernames_matched [lrange $leadernames 0 [llength $queryargs]-1] + foreach q $queryargs lname $leadernames_matched { + if {$lname eq ""} { + break + } + set arginfo [dict get $spec FORMS $fid ARG_INFO $lname] + + set allchoices [list] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + set choiceinfo [punk::args::system::Dict_getdef $arginfo -choiceinfo {}] + set is_ensembleparam [punk::args::system::Dict_getdef $arginfo -ensembleparameter 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 {*}$clist + } + if {$is_ensembleparam} { + #review + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + if {![llength $allchoices]} { + #review - only leaders with a defined set of choices are eligible for consideration as a subcommand + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + + + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + break + } + if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { + #a unique prefix is not sufficient for this arg + break + } + + lappend nextqueryargs $resolved_q + lpop queryargs_untested 0 + if {$resolved_q ne $q} { + #we have our first difference - recurse with new query args + set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested] + set sub_resolution [punk::ns::resolve_command {*}$resolvelist] + #return $sub_resolution + + set sub_origin [dict get $sub_resolution origin] + set sub_argsremaining [dict get $sub_resolution args_remaining] + set sub_resolved [dict get $sub_resolution resolved] + set sub_cmdtype [dict get $sub_resolution cmdtype] + set sub_args_full [dict get $sub_resolution args_full] + puts stderr "===> $sub_resolution" + + return [dict create origin $sub_origin args_remaining $sub_argsremaining resolved $sub_resolved cmdtype $sub_cmdtype args_full $resolvelist] + + } + #check if subcommands so far have a custom args def + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set spec [punk::args::get_spec $currentid] + set form_names [dict get $spec form_names] + set fid [lindex $form_names 0] + + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] + + if {[llength $form_names] != 1} { + break + } + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + if {[llength $optnames] || [llength $valnames]} { + break + } + } else { + set is_subcommand_resolved 0 + set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] + set mapped_subcmd "" + foreach inf $cinfo { + if {[lindex $inf 0] eq "resolved"} { + set mapped_subcmd [lindex $inf 1] + set resolve_next [list {*}$mapped_subcmd {*}$queryargs_untested] + puts "---> resolve_next: $resolve_next" + set sub_resolution [punk::ns::resolve_command {*}$resolve_next] + + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + #set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs] + + puts stderr "---> $sub_resolution" + puts stderr "---> $f" + dict set sub_resolution args_full $f + return $sub_resolution + + + #puts stderr "---> $sub_resolution" + #return $sub_resolution + } + } + + #We can get no further with custom defs + #It is possible we have a documented lower level subcommand but missing the intermediate + #e.g if ::trace remove command was specified and is documented - it will be found above + #but if ::trace remove is not documented and the query is "::trace remove com" + #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + #that's probably ok. + break + } + } + } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs + } + } + + if {[string match (autodef)* $origin]} { + set origin [string range $origin 9 end] + } + + + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + punk::args::define { + @id -id ::punk::ns::forms + @cmd -name punk::ns::forms -help\ + "Return names for each form of a command" + @opts + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc forms {args} { + set argd [::punk::args::parse $args withid ::punk::ns::forms] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::forms $id + } + punk::args::define { + @id -id ::punk::ns::synopsis + @cmd -name punk::ns::synopsis -help\ + "Return synopsis for each form of a command + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc synopsis {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set opt_return [dict get $argd opts -return] + set cmdmembers [dict get $argd values cmditem] + + + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set resolved_id [dict get $cmdinfo origin] + set unresolved_args [dict get $cmdinfo args_remaining] + set full_args [dict get $cmdinfo args_full] + + #puts "---punk::args::synopsis resolve_command result: $cmdinfo" + #REVIEW + set n [llength $unresolved_args] + set idparts [lrange $full_args 0 end-$n] + + set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + if {$syn eq ""} { + return + } + + #when we use list operations on $syn - it can get extra braces due to ANSI - use join to bring back to a string without extraneous bracing + switch -- $opt_return { + full - summary { + set resultstr "" + foreach synline [split $syn \n] { + #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n + append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + } + set resultstr [string trimright $resultstr \n] + #set resultstr [join [lreplace $syn 0 0 {*}$idparts] " "] + return $resultstr + } + dict { + return $syn + } + } + } + proc synopsis_raw {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::synopsis -form $form $id + } + #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? # - as this is interactive generally introspection should be ok at the top level # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? @@ -1989,15 +2596,15 @@ tcl::namespace::eval punk::ns { It supports the following: 1) Procedures or builtins for which a punk::args definition has been loaded. - 2) tepam procedures (returns string form only) + 2) tepam procedures (returns string form only) 3) ensemble commands - auto-generated unless documented via punk::args (subcommands will show with an indicator if they are explicitly documented or are themselves ensembles) - 4) tcl::oo objects - auto-gnerated unless documented via punk::args + 4) tcl::oo objects - auto-gnerated unless documented via punk::args 5) dereferencing of aliases to find underlying command (will not work with some renamed aliases) - Note that native commands commands not explicitly documented will + Note that native commands commands not explicitly documented will generally produce no useful info. For example sqlite3 dbcmd objects could theoretically be documented - but as 'info cmdtype' just shows 'native' they can't (?) be identified as belonging to sqlite3 without @@ -2009,7 +2616,8 @@ tcl::namespace::eval punk::ns { } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - + -form -default 0 -help\ + "Ordinal index or name of command form" -- -type none -help\ "End of options marker Use this if the command to view begins with a -" @@ -2026,19 +2634,21 @@ tcl::namespace::eval punk::ns { #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { - dict set opts -scheme info + #dict set opts -scheme info + set scheme_received 0 + } else { + set scheme_received 1; #so we know not to override caller's explicit choice } set querycommand [dict get $values commandpath] set queryargs [dict get $values subcommand] #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented if {[string match ::* $querycommand]} { set targetns [nsprefix $querycommand] set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global + #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global #when arginfo given a fully qualified path - we only want an answer for that exact command set nscommands [info commands ${targetns}::*] if {[lsearch -exact $nscommands $querycommand] >= 0} { @@ -2051,14 +2661,14 @@ tcl::namespace::eval punk::ns { set resolved $querycommand } } else { - #fully qualified command specified but doesn't exist + #fully qualified command specified but doesn't exist set origin $querycommand set resolved $querycommand } } else { #relative comandpath if {[string match (autodef)* $querycommand]} { - #pass through - should be found with id lookup + #pass through - should be found with id lookup set origin $querycommand set resolved $querycommand } else { @@ -2091,6 +2701,9 @@ tcl::namespace::eval punk::ns { ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] if {$nscaller ne "::"} { + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] } @@ -2104,9 +2717,32 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { + #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { - return [uplevel 1 [list punk::args::usage {*}$opts $origin]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } } } } @@ -2116,7 +2752,7 @@ tcl::namespace::eval punk::ns { switch -- $initial_cmdtype { na - alias { #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) + #consider using which_alias (wiki) set tgt [interp alias "" $origin] if {$tgt eq ""} { set tgt [interp alias "" [string trimleft $origin :]] @@ -2133,9 +2769,12 @@ tcl::namespace::eval punk::ns { #(possible curried arguments) #review - curried arguments could be for ensembles! set targetword $word1 - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] #puts "ALIAS THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] } @@ -2167,9 +2806,33 @@ tcl::namespace::eval punk::ns { #REVIEW - this doesn't cater for prefix callable subcommands set argcopy $queryargs if {[llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "====>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists [list $id {*}$queryargs]]} { - return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + } } } #while {[llength $argcopy]} { @@ -2182,21 +2845,46 @@ tcl::namespace::eval punk::ns { #didn't find any exact matches #traverse from other direction taking prefixes into account - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists $id]} { #cycle forward through leading values - set spec [punk::args::get_spec $id] + set specid $id + set specargs $queryargs if {[llength $queryargs]} { - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + #jjj + set spec [punk::args::get_spec $id] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs set queryargs_untested $queryargs foreach q $queryargs { - if {[llength [dict get $spec LEADER_NAMES]]} { - set subitems [dict get $spec LEADER_NAMES] + if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + set subitems [dict get $spec FORMS $fid LEADER_NAMES] if {[llength $subitems]} { set next [lindex $subitems 0] - set arginfo [dict get $spec ARG_INFO $next] + set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - set allchoices [list] + set allchoices [list] set choices [punk::args::system::Dict_getdef $arginfo -choices {}] set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] if {[dict exists $choicegroups ""]} { @@ -2214,18 +2902,45 @@ tcl::namespace::eval punk::ns { lappend nextqueryargs $resolved_q lpop queryargs_untested 0 if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - #set numvals [expr {[llength $queryargs]+1}] + #we have our first difference - recurse with new query args + #set numvals [expr {[llength $queryargs]+1}] #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - return [ punk::ns::arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested] + if {!$scheme_received} { + dict unset opts -scheme + } + return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] } #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list $id {*}$nextqueryargs] + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] if {[punk::args::id_exists $currentid]} { set spec [punk::args::get_spec $currentid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] } else { #We can get no further with custom defs #It is possible we have a documented lower level subcommand but missing the intermediate @@ -2242,8 +2957,34 @@ tcl::namespace::eval punk::ns { } } } else { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs } } @@ -2261,10 +3002,10 @@ tcl::namespace::eval punk::ns { #the call: info object methods -all # seems to do the right thing as far as hiding unexported methods, and showing things like destroy # - which don't seem to be otherwise easily introspectable - set public_methods [info object methods $origin -all] + set public_methods [info object methods $origin -all] #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - + if {[llength $queryargs]} { set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { @@ -2277,13 +3018,13 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} new" -help\ "create object with specified command name. Arguments are passed to the constructor." - @values + @values }] set i 0 foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2294,7 +3035,31 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin new"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin new"] + } } create { set constructorinfo [info class constructor $origin] @@ -2304,7 +3069,7 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} create" -help\ "create object with specified command name. Arguments following objectName are passed to the constructor." - @values -min 1 + @values -min 1 objectName -type string -help\ "possibly namespaced name for object instance command" }] @@ -2312,7 +3077,7 @@ tcl::namespace::eval punk::ns { foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2323,29 +3088,77 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin create"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin create"] + } } destroy { #review - generally no doc # but we may want notes about a specific destructor set argdef [punk::lib::tstr -return string { - @id -id "(audodef)${$origin} destroy" + @id -id "(autodef)${$origin} destroy" @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." @values -min 0 -max 0 }] punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + } } default { - #use info object call to resolve callchain + #use info object call to resolve callchain #we assume the first impl is the topmost in the callchain # and its call signature is therefore the one we are interested in - REVIEW # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? set implementations [::info object call $origin $c1] - #result documented as list of 4 element lists - #set callinfo [lindex $implementations 0] + #result documented as list of 4 element lists + #set callinfo [lindex $implementations 0] set oodef "" foreach impl $implementations { lassign $impl generaltype mname location methodtype @@ -2396,7 +3209,7 @@ tcl::namespace::eval punk::ns { switch -- [llength $a] { 1 { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2422,6 +3235,7 @@ tcl::namespace::eval punk::ns { } } set choicelabeldict [dict create] + set choiceinfodict [dict create] foreach cmd $public_methods { switch -- $cmd { new - create - destroy { @@ -2437,13 +3251,16 @@ tcl::namespace::eval punk::ns { if {$location eq "object"} { #set id "[string trimleft $origin :] $cmd" ;# " " set id "$origin $cmd" + dict set choiceinfodict $cmd {{doctype ooo}} } else { #set id "[string trimleft $location :] $cmd" ;# " " set id "$location $cmd" + dict set choiceinfodict $cmd {{doctype ooc}} } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { - dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + dict lappend choiceinfodict $cmd {doctype punkargs} } } break @@ -2451,6 +3268,7 @@ tcl::namespace::eval punk::ns { filter { } unknown { + dict set choiceinfodict $cmd {{doctype unknown}} } } } @@ -2458,11 +3276,11 @@ tcl::namespace::eval punk::ns { } } - set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review + set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" set idauto "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$idauto} + @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @leaders -min 1 @@ -2492,6 +3310,7 @@ tcl::namespace::eval punk::ns { #presumably -choiceprefix should be zero in that case?? set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] set prefixes [dict get $ensembleinfo -prefixes] set map [dict get $ensembleinfo -map] set ns [dict get $ensembleinfo -namespace] @@ -2537,54 +3356,142 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] if {[llength $queryargs]} { - set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs } - } - - set namespaces [list] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set ns [::namespace which $subwhat] - if {$ns ni $namespaces} { - lappend namespaces $ns + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + if {!$scheme_received} { + dict unset opts -scheme + } + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #use tailcall so %caller% is reported properly in error msg + tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + } } } + set have_usageinfo [list] set is_ensemble [list] set is_object [list] - foreach ns $namespaces { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin [nsprefix $ns] *]] 0] - lappend have_usageinfo {*}[dict get $nsinfo usageinfo] - lappend is_ensemble {*}[dict get $nsinfo ensembles] - lappend is_object {*}[dict get $nsinfo ooobjects] + set is_class [list] + set is_native [list] + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + if {$targettail in [dict get $nsinfo usageinfo]} { + lappend have_usageinfo $sub + } + if {$targettail in [dict get $nsinfo ensembles]} { + lappend is_ensemble $sub + } + if {$targettail in [dict get $nsinfo ooobjects]} { + lappend is_object $sub + } + if {$targettail in [dict get $nsinfo ooclasses]} { + lappend is_class $sub + } + if {$targettail in [dict get $nsinfo native]} { + lappend is_native $sub + } } + #todo - synopsis? set choicelabeldict [dict create] + + set choiceinfodict [dict create] foreach sub $subcommands { + + if {$sub in $is_ensemble} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + + if {$sub in $is_object} { + if {$sub in $is_class} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$sub in $is_native} { + dict lappend choiceinfodict $sub {doctype native} + } + if {$sub in $have_usageinfo} { - dict set choicelabeldict $sub " [Usageinfo_mark brightgreen]" - } elseif {$sub in $is_ensemble} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" - } elseif {$sub in $is_object} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" + #dict set choiceinfodict $sub [list {doctype punkargs}] + dict lappend choiceinfodict $sub {doctype punkargs} } } - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] set autoid "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} + @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @leaders -min 1 }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } + } append argdef \n $vline punk::args::define $argdef - return [punk::args::usage {*}$opts $autoid] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { + # parsing error e.g Bad number of leading values + #override -scheme in opts with -scheme error + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] + } + #return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2650,14 +3557,41 @@ tcl::namespace::eval punk::ns { } if {[llength $queryargs]} { - #todo - something better - set msg "Undocumented or nonexistant subcommand $origin $queryargs" + #todo - something better ? + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + + if {[punk::args::id_exists $origin]} { + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } + } + set msg "Undocumented or nonexistant command $origin $queryargs" append msg \n "$origin Type: $cmdtype" } else { if {$cmdtype eq "proc"} { set msg "Undocumented proc $origin" append msg \n "No argument processor detected" - append msg \n "function signature: $resolved $argl" + append msg \n "function signature: $resolved $argl" } else { set msg "Undocumented command $origin. Type: $cmdtype" } @@ -2667,15 +3601,15 @@ tcl::namespace::eval punk::ns { #todo - package up as navns proc corp {path} { - #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp + #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) if {[info exists punk::console::tabwidth]} { set tw $::punk::console::tabwidth } else { - set tw 8 + set tw 8 } - set indent [string repeat " " $tw] ;#match - #set indent [string repeat " " $tw] ;#A more sensible default for code - review + set indent [string repeat " " $tw] ;#match + #set indent [string repeat " " $tw] ;#A more sensible default for code - review if {[info exists ::auto_index($path)]} { set body "\n${indent}#corp# auto_index $::auto_index($path)" @@ -2695,7 +3629,7 @@ tcl::namespace::eval punk::ns { } #puts stderr "corp upns:$upns" - #set name [string trim $name :] + #set name [string trim $name :] #set origin [namespace origin ${upns}::$name] set origin [nseval $targetns [list ::namespace origin $name]] set resolved [nseval $targetns [list ::namespace which $name]] @@ -2703,7 +3637,7 @@ tcl::namespace::eval punk::ns { #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! if {$origin ni [info procs $origin]} { - #It seems an interp alias of "::x"" behaves the same as "x" + #It seems an interp alias of "::x"" behaves the same as "x" #But we can't create both at the same time - and they have to be queried by the exact name. #So we query for alias with and without leading :: set alias_qualified [interp alias {} [string trim $origin :]] @@ -2727,7 +3661,7 @@ tcl::namespace::eval punk::ns { #depending on number of aliases in the chain return [list alias {*}$alias] } - } + } if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { append body \n "${indent}#corp# namespace origin $origin" } @@ -2737,7 +3671,7 @@ tcl::namespace::eval punk::ns { } if {![catch {package require textutil::tabify} errpkg]} { set bodytext [info body $origin] - #punk::lib::indent preserves trailing empty lines - unlike textutil version + #punk::lib::indent preserves trailing empty lines - unlike textutil version set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] append body [punk::lib::indent $bodytext $indent] } else { @@ -2880,17 +3814,17 @@ tcl::namespace::eval punk::ns { set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] if {!$ns_populated} { - #we will catch-run an auto_index entry if any - #auto_index entry may or may not be prefixed with :: + #we will catch-run an auto_index entry if any + #auto_index entry may or may not be prefixed with :: set keys [list] #first look for exact pkg_unqualified and ::pkg_unqualified #leave these at beginning of keys list if {[array exists ::auto_index($pkg_unqualified)]} { - lappend keys $pkg_unqualified - } + lappend keys $pkg_unqualified + } if {[array exists ::auto_index(::$pkg_unqualified)]} { - lappend keys ::$pkg_unqualified - } + lappend keys ::$pkg_unqualified + } #as auto_index is an array - we could get keys in arbitrary order set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]] lappend keys {*}$matches @@ -2902,8 +3836,8 @@ tcl::namespace::eval punk::ns { set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] while {!$ns_populated && $i < [llength $keys]} { #todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base - #e.g if we are loading ::x::y - #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc + #e.g if we are loading ::x::y + #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc set k [lindex $keys $i] set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { @@ -2916,7 +3850,7 @@ tcl::namespace::eval punk::ns { } incr i } - + } } } @@ -2924,7 +3858,7 @@ tcl::namespace::eval punk::ns { if {[llength $cmdargs]} { set binding {} #if {[info level] == 1} { - # #up 1 is global + # #up 1 is global # set get_vars [list info vars] #} else { # set get_vars [list info locals] @@ -2955,7 +3889,7 @@ tcl::namespace::eval punk::ns { } else { #A variable can show in the results for 'info vars' (or nsvars) but still not exist. e.g a 'variable x' declaration in the namespace where the variable has never been set } - } + } return [dict create vars $capturevars arrs $capturearrs] } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) } ] @@ -2963,7 +3897,7 @@ tcl::namespace::eval punk::ns { set arglist [lassign $cmdargs scriptblock] if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} { - #one liner without use of $args + #one liner without use of $args append scriptblock { {*}$args} #tailcall apply [list args [string cat $scriptblock { {*}$args}] $ns] {*}$arglist } @@ -3043,7 +3977,7 @@ tcl::namespace::eval punk::ns { error "nsimport_noclobber error namespace $source_ns not found" } - set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] + set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] set a_commands [info commands $pat] #puts "-->commands:'$a_commands'" set a_tails [lmap v $a_commands {tcl::namespace::tail $v}] @@ -3053,11 +3987,11 @@ tcl::namespace::eval punk::ns { foreach m $matches { #we will be using namespace import one by one on commands. #we must protect glob chars that may exist in the actual command names. - #e.g nsimport_noclobber ::punk::ansi::a? + #e.g nsimport_noclobber ::punk::ansi::a? # will import a+ and a? #but nsimport_noclobber {::punk::ansi::a\?} # must import only a? - set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] + set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] if {$m ni $a_exported_tails} { lappend a_exported_tails $m } @@ -3071,7 +4005,7 @@ tcl::namespace::eval punk::ns { set imported_commands [list] if {[namespace exists $nstemp]} { namespace delete $nstemp - } + } namespace eval $nstemp {} foreach e $a_exported_tails { set imported [apply {{tgtns func srcns pfx tmpns} { @@ -3151,13 +4085,13 @@ tcl::namespace::eval punk::ns { @id -id ::i+ @cmd -name "i+" -help\ "Display command help side by side" - @values - cmds -multiple 1 -help\ + @values + cmd -multiple 1 -help\ "Command names for which to show help info" } interp alias {} i+ {}\ .=args> punk::args::get_by_id ::i+ |argd>\ - .=>2 dict get values cmds |cmds>\ + .=>2 dict get values cmd |cmds>\ .=cmds>2 lmap c {i -return tableobject {*}$c} |objs>\ .=objs>2 lmap t {$t configure -show_vseps 0 -show_edge 1} |>\ .=objs>2 lmap t {$t print} |tables>\ @@ -3179,9 +4113,9 @@ tcl::namespace::eval punk::ns { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index d823a923..317fc9de 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -174,7 +174,7 @@ tcl::namespace::eval punk::packagepreference { set is_exact 1 } else { set pkg [lindex $args 1] - set vwant [lrange $args 2 end] ;#rare - but version can be a list of options + set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index a39fceaf..2ab1fb01 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -100,8 +100,12 @@ namespace eval punk::repo { subcommand -type string -choicecolumns 8 -choicegroups { "frequently used commands" {${$maincommands}} "" {${$othercmds}} - } + } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} }] + #-choiceinfo { + # add {{doctype punkargs}} + # diff {{doctype punkargs}} + #} return $result } @@ -112,7 +116,7 @@ namespace eval punk::repo { # @id -id ::punk::repo::fossil_proxy # @cmd -name fossil -help "fossil executable # " - # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}} # } ""] lappend PUNKARGS [list { @@ -129,7 +133,7 @@ namespace eval punk::repo { @dynamic @id -id "::punk::repo::fossil_proxy diff" @cmd -name "fossil diff" -help "fossil diff" - @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} + @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} } ""] lappend PUNKARGS [list { #todo - remove this comment - testing dynamic directive @@ -137,7 +141,7 @@ namespace eval punk::repo { @id -id "::punk::repo::fossil_proxy add" @cmd -name "fossil add" -help "fossil add " - @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} } ""] #TODO #lappend PUNKARGS [list { @@ -145,7 +149,7 @@ namespace eval punk::repo { # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @cmd -name "fossil add" -help "fossil add # " - # @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # } ""] lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm index 99bc359d..4ba74656 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip { expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) | ($hour << 11) | ($min << 5) | ($sec >> 1)} } - + punk::args::define { + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -help\ + "Walk the directory structure starting at base/<-subpath> + and return a list of the files and folders encountered. + Resulting paths are relative to base unless -resultrelative + is supplied. + Folder names will end with a trailing slash. + " + -resultrelative -optional 1 -help\ + "Resulting paths are relative to this value. + Defaults to the value of base. If empty string + is given to -resultrelative the paths returned + are effectively absolute paths." + -emptydirs -default 0 -type boolean -help\ + "Whether to include directory trees in the result which had no + matches for the given fileglobs. + Intermediate dirs are always returned if there is a match with + fileglobs further down even if -emptdirs is 0. + " + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" -help\ + "May contain glob chars for folder elements" + @values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } proc walk {args} { #*** !doctools #[call [fun walk] [arg ?options?] [arg base]] #[para] Walk a directory tree rooted at base #[para] the -excludes list can be a set of glob expressions to match against files and avoid - #[para] e.g + #[para] e.g #[example { # punk::zip::walk -exclude {CVS/* *~.#*} library #}] #todo: -relative 0|1 flag? - set argd [punk::args::get_dict { - @id -id ::punk::zip::walk - @cmd -name punk::zip::walk -help\ - "Walk the directory structure starting at base/<-subpath> - and return a list of the files and folders encountered. - Resulting paths are relative to base unless -resultrelative - is supplied. - Folder names will end with a trailing slash. - " - -resultrelative -optional 1 -help\ - "Resulting paths are relative to this value. - Defaults to the value of base. If empty string - is given to -resultrelative the paths returned - are effectively absolute paths." - -emptydirs -default 0 -type boolean -help\ - "Whether to include directory trees in the result which had no - matches for the given fileglobs. - Intermediate dirs are always returned if there is a match with - fileglobs further down even if -emptdirs is 0. - " - -excludes -default "" -help "list of glob expressions to match against files and exclude" - -subpath -default "" -help\ - "May contain glob chars for folder elements" - @values -min 1 -max -1 - base - fileglobs -default {*} -multiple 1 - } $args] + set argd [punk::args::parse $args withid ::punk::zip::walk] set base [dict get $argd values base] set fileglobs [dict get $argd values fileglobs] set subpath [dict get $argd opts -subpath] @@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip { + punk::args::define { + @id -id ::punk::zip::Addentry + @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + @opts + -comment -default "" -help "An optional comment specific to the added file" + @values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } + # Addentry - was Mkzipfile -- # # FIX ME: should handle the current offset for non-seekable channels @@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip { #[para] You can provide a -comment for the file. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. - set argd [punk::args::get_dict { - @id -id ::punk::zip::Addentry - @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' - return a central directory file record" - @opts - -comment -default "" -help "An optional comment specific to the added file" - @values -min 3 -max 4 - zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" - base -help "base path for entries" - path -type file -help "path of file to add" - zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe - Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::Addentry] set zipchan [dict get $argd values zipchan] set base [dict get $argd values base] set path [dict get $argd values path] @@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip { # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) #### + + punk::args::define { + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" + @opts + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix. + " + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + " + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided. + Note that this will + " + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + + @values -min 1 -max -1 + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." + } + # zip::mkzip -- # # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt - # + # proc mkzip {args} { #todo - doctools - [arg ?globs...?] syntax? @@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip { #[para] If a file already exists, an error will be raised. #[para] Call 'punk::zip::mkzip' with no arguments for usage display. - set argd [punk::args::get_dict { - @id -id ::punk::zip::mkzip - @cmd -name punk::zip::mkzip\ - -help "Create a zip archive in 'filename'" - @opts - -offsettype -default "archive" -choices {archive file}\ - -help "zip offsets stored relative to start of entire file or relative to start of zip-archive - Only relevant if the created file has a script/runtime prefix. - " - -return -default "pretty" -choices {pretty list none}\ - -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none\ - -help "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs - " - -runtime -default ""\ - -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review) - " - -comment -default ""\ - -help "An optional comment for the archive" - -directory -default ""\ - -help "The new zip archive will scan for contents within this folder or current directory if not provided. - Note that this will - " - -base -default ""\ - -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" - -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - - @values -min 1 -max -1 - filename -type file -default ""\ - -help "name of zipfile to create" - globs -default {*} -multiple 1\ - -help "list of glob patterns to match. - Only directories with matching files will be included in the archive." - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::mkzip] set filename [dict get $argd values filename] if {$filename eq ""} { error "mkzip filename cannot be empty string" 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 9f4e75ee..ebd18fc1 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 @@ -140,16 +140,18 @@ tcl::namespace::eval textblock { # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # "algorithm choice" - - punk::args::define { - @dynamic - @id -id ::textblock::use_hash - @cmd -name "textblock::use_hash" -help\ - "Hashing algorithm to use for framecache lookup. - 'none' may be slightly faster but less compact - when viewing textblock::framecache" - @values -min 0 -max 1 - hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} + namespace eval argdoc { + set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]} + punk::args::define { + @dynamic + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP} + } } proc use_hash {args} { #set argd [punk::args::get_by_id ::textblock::use_hash $args] @@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock { -size -type integer\ -default 15\ -optional 1\ - -range {1 15} + -range {1 ""} -direction -default horizontal\ -choices {horizontal vertical}\ -help\ - "When rainbow is in the colour list, - this also affects the direction of - colour changes" - @values -min 0 -max 2 + "Direction of character increments. + When rainbow is in the colour list, + the colour stripes will be oriented + in this direction. + " + @values -min 0 -max 1 colour -type list -default {} -optional 1 -help\ "List of Ansi colour names - e.g. testblock 10 {white Red} + e.g. testblock -size 10 {white Red} produces a block of character 10x10 with white text on red bacground @@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock { set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + if {$size <= 15} { + set charsubset [lrange $chars 0 $size-1] + } else { + set numsets [expr {int(ceil($size / 15.0))}] + set longset [concat {*}[lrepeat $numsets $chars]] + set charsubset [lrange $longset 0 $size-1] + + set longbows [concat {*}[lrepeat $numsets $rainbow_list]] + set rainbow_list [lrange $longbows 0 $size-1] + } if {"noreset" in $colour} { set RST "" } else { @@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock { append row $c } append row $RST - append block $row\n + append block $row \n } set block [tcl::string::trimright $block \n] return $block } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST + if {$direction eq "vertical"} { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block + } else { + set block "" + for {set r 0} {$r < $size} {incr r} { + append block [::join $charsubset ""] \n + } + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block } - return $block } } interp alias {} testblock {} textblock::testblock @@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock { proc ::textblock::join1 {args} { - lassign [punk::args::get_dict { + lassign [punk::args::parse $args withdef { + @id -id ::textblock::join1 -ansiresets -default 1 -type integer blocks -type string -multiple 1 - } $args] _l leaders _o opts _v values + }] _l leaders _o opts _v values set blocks [tcl::dict::get $values blocks] set idx 0 @@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock { #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner #" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::textblock::join_basic2 -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -ansiresets -type any -default auto blocks -type any -multiple 1 - } $args] + }] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock { #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #they may however still be 'ragged' ie differing line lengths proc ::textblock::join {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - #-ansireplays is always on (if ansi detected) #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets @@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock { } proc ::textblock::join2 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock { } # This calls textblock::pad per cell :/ proc ::textblock::join3 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock { NOTE: more options available - argument definition is incomplete" @opts - -return -choices {table tableobject} + -return -default table -choices {table tableobject} -rows -type list -default "" -help\ "A list of lists. Each toplevel element represents a row. @@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock { -help "restrict to keys matching memberglob." }] #append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args + punk::args::parse $args withdef $spec return } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index 9809dc62..b73cbac8 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -2044,6 +2044,10 @@ if {[file exists $mapfile]} { } # -- --- --- --- --- --- --- --- --- --- puts "-- runtime_vfs_map --" +set ver [package require punk::args] +puts "punk::args ver: $ver" +set ifneeded [package ifneeded punk::args $ver] +puts "punk::args ifneeded: $ifneeded" punk::lib::pdict runtime_vfs_map puts "---------------------" puts "-- vfs_runtime_map--" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm index 1ede846b..40366143 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application argparsingtest 0.1.0 # Meta platform tcl -# Meta license MIT +# Meta license MIT # @@ Meta End @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_argparsingtest 0 0.1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require argparsingtest] #[keywords module] #[description] @@ -106,7 +106,7 @@ namespace eval argparsingtest { #*** !doctools #[subsection {Namespace argparsingtest}] - #[para] Core API functions for argparsingtest + #[para] Core API functions for argparsingtest #[list_begin definitions] proc test1_ni {args} { @@ -277,8 +277,8 @@ namespace eval argparsingtest { #punk::args is slower than argp - but comparable, and argp doesn't support solo flags proc test1_punkargs {args} { set argd [punk::args::parse $args withdef { - @id -id ::argparsingtest::test1_punkargs - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -298,7 +298,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::test1_punkargs_by_id - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -320,7 +320,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::argparsingtest::test1_punkargs2 - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -334,7 +334,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -3 -default 3 -type integer @values - } + } proc test1_punkargs2 {args} { set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] return [tcl::dict::get $argd opts] @@ -342,9 +342,9 @@ namespace eval argparsingtest { proc test1_punkargs_validate_ansistripped {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs_validate_ansistripped - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string @@ -358,7 +358,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true @values - } $args] + }] return [tcl::dict::get $argd opts] } @@ -387,11 +387,11 @@ namespace eval argparsingtest { package require cmdline #cmdline::getoptions is much faster than typedGetoptions proc test1_cmdline_untyped {args} { - set cmdlineopts_untyped { - {return.arg "string" "return val"} + set cmdlineopts_untyped { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -405,11 +405,11 @@ namespace eval argparsingtest { return [::cmdline::getoptions args $cmdlineopts_untyped $usage] } proc test1_cmdline_typed {args} { - set cmdlineopts_typed { - {return.arg "string" "return val"} + set cmdlineopts_typed { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -465,7 +465,7 @@ namespace eval argparsingtest { #multiline values use first line of each record to determine amount of indent to trim proc test_multiline {args} { set t3 [textblock::frame t3] - set argd [punk::args::get_dict [subst { + set argd [punk::args::parse $args withdef [subst { -template1 -default { ****** * t1 * @@ -476,7 +476,7 @@ namespace eval argparsingtest { * t2 * ******} -template3 -default {$t3} - #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately + #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately -template3b -default { $t3 ----------------- @@ -491,20 +491,20 @@ namespace eval argparsingtest { " -flag -default 0 -type boolean - }] $args] + }]] return $argd } #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] - # return "ok" + # return "ok" #} @@ -524,14 +524,14 @@ namespace eval argparsingtest::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace argparsingtest::lib}] - #[para] Secondary functions that are part of the API + #[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 + # #[para]Description of utility1 + # return 1 #} @@ -549,17 +549,17 @@ namespace eval argparsingtest::lib { namespace eval argparsingtest::system { #*** !doctools #[subsection {Namespace argparsingtest::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide argparsingtest [namespace eval argparsingtest { variable pkg argparsingtest variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm index 7884214c..b2561a20 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm @@ -99,8 +99,11 @@ namespace eval commandstack { } } - proc get_stack {command} { + proc get_stack {{command ""}} { variable all_stacks + if {$command eq ""} { + return $all_stacks + } set command [uplevel 1 [list namespace which $command]] if {[dict exists $all_stacks $command]} { return [dict get $all_stacks $command] @@ -116,6 +119,7 @@ namespace eval commandstack { variable all_stacks if {[dict exists $all_stacks $command]} { set stack [dict get $all_stacks $command] + #stack is a list of dicts, 1st entry is token { } set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] if {$posn > -1} { set record [lindex $stack $posn] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.3.tm index 44da4684..540a1696 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.3.tm @@ -134,12 +134,12 @@ namespace eval modpod { #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::connect -type -default "" @values -min 1 -max 1 path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] + }] catch { punk::lib::showdict $argd ;#heavy dependencies } @@ -168,7 +168,7 @@ namespace eval modpod { } else { #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) set this_pkg_tm_folder [file dirname $modpodpath] if {$connected(type,$modpodpath) ne "unwrapped"} { #Not directly connected to unwrapped version - but may still be redirected there @@ -225,11 +225,15 @@ namespace eval modpod { if {$connected(startdata,$modpodpath) >= 0} { #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { seek $fh $connected(startdata,$modpodpath) start return [list ok $fh] } else { #error "cannot verify tar header" + #try zipfs + if {[info commands tcl::zipfs::mount] ne ""} { + + } } } lpop connected(to) end @@ -262,11 +266,12 @@ namespace eval modpod { return 1 } proc get {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::modpod::get -from -default "" -help "path to pod" - *values -min 1 -max 1 + @values -min 1 -max 1 filename - } $args] + }] set frompod [dict get $argd opts -from] set filename [dict get $argd values filename] @@ -329,7 +334,7 @@ namespace eval modpod::lib { #zipfile is a pure zip at this point - ie no script/exe header proc make_zip_modpod {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::modpod::lib::make_zip_modpod -offsettype -default "archive" -choices {archive file} -help\ "Whether zip offsets are relative to start of file or start of zip-data within the file. @@ -340,7 +345,7 @@ namespace eval modpod::lib { @values -min 2 -max 2 zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] + }] set zipfile [dict get $argd values zipfile] set outfile [dict get $argd values outfile] set opt_offsettype [dict get $argd opts -offsettype] @@ -359,7 +364,7 @@ namespace eval modpod::lib { set moddir [file dirname $modfile] set mod_and_ver [file rootname [file tail $modfile]] lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { + if {[file exists $moddir/#modpod-$mod_and_ver]} { source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm } else { #determine module namespace so we can mount appropriately diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index c7207cc0..fd638812 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore { smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ config ::punk::config\ + s ::punk::ns::synopsis\ ] #*** !doctools diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index f671311f..a7fe1047 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu foreach {pt code} $parts { switch -- [llength $codestack] { 0 { - append emit $base$pt$R + append emit $base $pt $R } 1 { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { - append emit $base$pt$R + append emit $base $pt $R set codestack [list] } else { #append emit [lindex $o_codestack 0]$pt if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } default { if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } @@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append emit $code } } - return $emit$R + return [append emit $R] } else { return $base$text$R } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.6.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.6.tm new file mode 100644 index 00000000..c3bf04b8 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.6.tm @@ -0,0 +1,6400 @@ +# -*- 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.6 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.6] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $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_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + #set val_min $v + dict set F $fid VAL_MIN $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #now cycle through ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set 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]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + #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::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + 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 parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + 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(goodarg) [a+ green strike] + set CLR(goodchoice) [a+ reverse] + 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(goodarg) [a+ strike] + 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 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $form_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $form_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + set id [lindex $tailargs 0] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + + 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-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } 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 + + #JJJJ + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$valmax == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $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 <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $valname_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $validx}] + } + #------------------------------------------ + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + 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 + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -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 + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer 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 + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.6 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.7.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.7.tm new file mode 100644 index 00000000..b04f4966 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.7.tm @@ -0,0 +1,6458 @@ +# -*- 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.7 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.7] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache [list $optionspecs]] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + + #set opt_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + #set val_min $v + dict set F $fid VAL_MIN $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #now cycle through ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$deflist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set deflist [raw_def $id] + if {$deflist eq ""} { + return + } + return [resolve {*}$deflist] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + variable arg_error_CLR + array set arg_error_CLR {} + set arg_error_CLR(errormsg) [a+ brightred] + set arg_error_CLR(title) "" + set arg_error_CLR(check) [a+ brightgreen] + set arg_error_CLR(solo) [a+ brightcyan] + set arg_error_CLR(choiceprefix) [a+ underline] + set arg_error_CLR(badarg) [a+ brightred] + set arg_error_CLR(goodarg) [a+ green strike] + set arg_error_CLR(goodchoice) [a+ reverse] + set arg_error_CLR(linebase_header) [a+ white] + set arg_error_CLR(cmdname) [a+ brightwhite] + set arg_error_CLR(groupname) [a+ bold] + set arg_error_CLR(ansiborder) [a+ bold] + set arg_error_CLR(ansibase_header) [a+ bold] + set arg_error_CLR(ansibase_body) [a+ white] + variable arg_error_CLR_nocolour + array set arg_error_CLR_nocolour {} + set arg_error_CLR_nocolour(errormsg) [a+ bold] + set arg_error_CLR_nocolour(title) [a+ bold] + set arg_error_CLR_nocolour(check) "" + set arg_error_CLR_nocolour(solo) "" + set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment + set arg_error_CLR_nocolour(goodarg) [a+ strike] + set arg_error_CLR_nocolour(cmdname) [a+ bold] + set arg_error_CLR_nocolour(linebase_header) "" + set arg_error_CLR_nocolour(linebase) "" + set arg_error_CLR_nocolour(ansibase_body) "" + variable arg_error_CLR_info + array set arg_error_CLR_info {} + set arg_error_CLR_info(errormsg) [a+ brightred bold] + set arg_error_CLR_info(title) [a+ brightyellow bold] + set arg_error_CLR_info(check) [a+ brightgreen bold] + set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_info(groupname) [a+ cyan bold] + set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] + set arg_error_CLR_info(ansibase_header) [a+ cyan] + set arg_error_CLR_info(ansibase_body) [a+ white] + variable arg_error_CLR_error + array set arg_error_CLR_error {} + set arg_error_CLR_error(errormsg) [a+ brightred bold] + set arg_error_CLR_error(title) [a+ brightcyan bold] + set arg_error_CLR_error(check) [a+ brightgreen bold] + set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_error(groupname) [a+ cyan bold] + set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] + set arg_error_CLR_error(ansibase_header) [a+ yellow] + set arg_error_CLR_error(ansibase_body) [a+ white] + + + #bas ic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + upvar ::punk::args::arg_error_CLR CLR + + switch -- $scheme { + nocolour { + variable arg_error_CLR_nocolour + array set CLR [array get arg_error_CLR_nocolour + } + info { + variable arg_error_CLR_info + array set CLR [array get arg_error_CLR_info] + } + error { + variable arg_error_CLR_error + array set CLR [array get arg_error_CLR_error] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + #if {"$argdisplay_header$argdisplay_body" eq ""} { + # set is_custom_argdisplay 0 + #} else { + # set is_custom_argdisplay 1 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $form_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $form_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + #unhappy path - not enough options + #review - which form of punk::args::parse? + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + set id [lindex $tailargs 0] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + + 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-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } 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 + + #JJJJ + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$valmax == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $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 <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $valname_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $validx}] + } + #------------------------------------------ + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + 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 + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -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 + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.7 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index aaa595ae..2d949ccf 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates { namespace export * namespace eval class { variable PUNKARGS - #set argd [punk::args::get_dict { - # @id -id "::punk::cap::handlers::templates::class::api folders" - # -startdir -default "" - # @values -max 0 - #} $args] - lappend PUNKARGS [list { - @id -id "::punk::cap::handlers::templates::class::api folders" - -startdir -default "" - @values -max 0 - }] + #lappend PUNKARGS [list { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #}] oo::class create api { #return a dict keyed on folder with source pkg as value @@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates { set cname [string map {. _} $capname] set capabilityname $capname } + set class_ns [uplevel 1 [list namespace current]] + + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + @cmd -name "punk::cap::handlers::templates::class::api folders" + -startdir -default "" -help\ + "Defaults to CWD if not supplied" + @values -max 0 + }] method folders {args} { #puts "--folders $args" - set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] + set argd [punk::args::parse $args withid "[self class] folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates { } return $folderdict } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" + @cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\ + "" + @opts -anyopts 1 + #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here + -startdir -default "" + @values -maxvalues -1 + }] method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" - @opts -anyopts 1 - #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here - -startdir -default "" - @values -maxvalues -1 - } $args] + + set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"] + set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { @@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates { my _get_itemdict {*}$arglist } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" + @cmd -name _get_itemdict + @opts -anyopts 0 + -startdir -default "" + -templatefolder_subdir -optional 0 + -command_get_items_from_base -optional 0 + -command_get_item_name -optional 0 + -not -default "" -multiple 1 + @values -maxvalues -1 + globsearches -default * -multiple 1 + }] + #shared algorithm for get_itemdict_* methods #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" - @cmd -name _get_itemdict - @opts -anyopts 0 - -startdir -default "" - -templatefolder_subdir -optional 0 - -command_get_items_from_base -optional 0 - -command_get_item_name -optional 0 - -not -default "" -multiple 1 - @values -maxvalues -1 - globsearches -default * -multiple 1 - } $args] + set argd [punk::args::parse $args withid "[self class] _get_itemdict"] + set opts [dict get $argd opts] set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results #puts stderr "=-=============>globsearches:$globsearches" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm index e278d99f..3a5f25b0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -44,8 +44,11 @@ tcl::namespace::eval punk::config { @values -min 0 -max 0 }] proc dir {args} { + #set be_quiet [dict exists $received -quiet] if {"-quiet" in $args} { - set be_quiet [dict exists $received -quiet] + set be_quiet 1 + } else { + set be_quiet 0 } set was_noisy 0 @@ -445,6 +448,7 @@ tcl::namespace::eval punk::config { "Get configuration values from a config. Accepts globs eg XDG*" @leaders -min 1 -max 1 + #todo - load more whichconfig choices? whichconfig -type string -choices {config startup-configuration running-configuration} @values -min 0 -max -1 globkey -type string -default * -optional 1 -multiple 1 @@ -526,18 +530,23 @@ tcl::namespace::eval punk::config { error "setting value not implemented" } - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::config::show - @cmd -name punk::config::get -help\ - "Display configuration values from a config. - Accepts globs eg XDG*" - @leaders -min 1 -max 1 - }\ - {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ - "@values -min 0 -max -1"\ - {${[punk::args::resolved_def -types values ::punk::config::get]}}\ - ] + namespace eval argdoc { + set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}} + set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}} + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${$DYN_GET_LEADERS}}\ + "@values -min 0 -max -1"\ + {${$DYN_GET_VALUES}}\ + ] + } proc show {args} { #todo - tables for console set configrecords [punk::config::get {*}$args] @@ -568,7 +577,7 @@ tcl::namespace::eval punk::config { toconfig -help\ "running or startup or file name (not fully implemented)" } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::parse $args withdef $argdef] set fromconfig [dict get $argd values fromconfig] set toconfig [dict get $argd values toconfig] set fromconfig [string map {-config ""} $fromconfig] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index adb47eff..7d1375d7 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -562,13 +562,13 @@ namespace eval punk::du { proc Get_attributes_from_iteminfo {args} { variable win_reparse_tags_by_int - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::Get_attributes_from_iteminfo -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" - } $args] + }] set opts [dict get $argd opts] set iteminfo [dict get $argd values iteminfo] set opt_debug [dict get $opts -debug] @@ -621,14 +621,14 @@ namespace eval punk::du { proc attributes_twapi {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::attributes_twapi -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" - } $args] + }] set opts [dict get $argd opts] set path [dict get $argd values path] set opt_detail [dict get $opts -detail] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index ca222524..86126a5c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib { } proc range_boundaries {start end chunksizes args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { -offset -default 0 - } $args] + }] lassign [dict values $argd] leaders opts remainingargs } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm new file mode 100644 index 00000000..5532ed33 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm @@ -0,0 +1,4237 @@ +# -*- 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::lib 0.1.2 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::lib 0 0.1.2] +#[copyright "2024"] +#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk library}] [comment {-- Description at end of page heading --}] +#[require punk::lib] +#[keywords module utility lib] +#[description] +#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. +#[para]The base set includes string and math functions but has no specific theme + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::lib +#[subsection Concepts] +#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. +#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::lib +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +tcl::namespace::eval punk::lib::ensemble { + #wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + proc extend {routine extension} { + if {![string match ::* $routine]} { + set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![string match ::* $extension]} { + set extension [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$extension + } + + if {![tcl::namespace::exists $extension]} { + error [list {no such namespace} $extension] + } + + set extension [tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] current]] + + tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] export *] + + while 1 { + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] + if {[tcl::namespace::which $renamed] eq {}} break + } + + rename $routine $renamed + + tcl::namespace::eval $extension [ + list namespace ensemble create -command $routine -unknown [ + list apply {{renamed ensemble routine args} { + list $renamed $routine + }} $renamed + ] + ] + + return $routine + } +} + +# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated +tcl::namespace::eval punk::lib::check { + proc has_tclbug_script_var {} { + + set script {set j [list spud] ; list} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + return true + } else { + return false + } + } + proc has_tclbug_lsearch_strideallinline {} { + #bug only occurs with single -index value combined with -stride -all -inline -subindices + #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d + if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { + #we aren't looking for an error result - error most likely indicates tcl too old to support -stride + return 0 + } + return [expr {$result ne "a2"}] + } + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { + #ensemble calls within safe interp not compiled + namespace eval [namespace current]::testcompile { + proc ensembletest {} {string index a 0} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr has_bug + } + return $has_bug + } +} + +tcl::namespace::eval punk::lib::compat { + #*** !doctools + #[subsection {Namespace punk::lib::compat}] + #[para] compatibility functions for features that may not be available in earlier Tcl versions + #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. + #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. + + #*** !doctools + #[list_begin definitions] + + + + + if {"::lremove" ne [info commands ::lremove]} { + #puts stderr "Warning - no built-in lremove" + interp alias {} lremove {} ::punk::lib::compat::lremove + } + proc lremove {list args} { + #*** !doctools + #[call [fun lremove] [arg list] [opt {index ...}]] + #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove + + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 + + if {![info exists ::auto_index(readFile)]} { + if {[info commands ::readFile] eq ""} { + proc ::readFile {filename {mode text}} { + #readFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + + # Read the file + set f [open $filename [dict get {text r binary rb} $mode]] + try { + return [read $f] + } finally { + close $f + } + } + } + } + if {![info exists ::auto_index(writeFile)]} { + if {[info commands ::writeFile] eq ""} { + proc ::writeFile {args} { + #writeFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + switch [llength $args] { + 2 { + lassign $args filename data + set mode text + } + 3 { + lassign $args filename mode data + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + } + default { + set COMMAND [lindex [info level 0] 0] + return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" + } + } + + # Write the File + set f [open $filename [dict get {text w binary wb} $mode]] + try { + puts -nonewline $f $data + } finally { + close $f + } + } + } + } + + if {"::lpop" ne [info commands ::lpop]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lpop + } + proc lpop {lvar args} { + #*** !doctools + #[call [fun lpop] [arg listvar] [opt {index}]] + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + + + #slight isolation - varnames don't leak - but calling context vars can be affected + proc lmaptcl2 {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result [apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + if {"::lmap" ne [info commands ::lmap]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lmap {} ::punk::lib::compat::lmaptcl + } + #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway + proc lmaptcl {varnames list script} { + set result [list] + set varlist [list] + foreach varname $varnames { + upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc + lappend varlist var_$varname + } + foreach $varlist $list { + lappend result [uplevel 1 $script] + } + return $result + } + + #tcl8.7/9 compatibility for 8.6 + if {[info commands ::tcl::string::insert] eq ""} { + #https://wiki.tcl-lang.org/page/string+insert + # Pure Tcl implementation of [string insert] command. + proc ::tcl::string::insert {string index insertString} { + # Convert end-relative and TIP 176 indexes to simple integers. + if {[regexp -expanded { + ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace + |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace + (?:([+-]) # op, omitted when index is "end" + ([+-]?\d+))? # n, omitted when index is "end" + [\t\n\v\f\r ]*$ # optional whitespace (unless "end") + } $index _ m op n]} { + # Convert first index to an integer. + switch $m { + end {set index [string length $string]} + default {scan $m %d index} + } + + # Add or subtract second index, if provided. + switch $op { + + {set index [expr {$index + $n}]} + - {set index [expr {$index - $n}]} + } + } elseif {![string is integer -strict $index]} { + # Reject invalid indexes. + return -code error "bad index \"$index\": must be\ + integer?\[+-\]integer? or end?\[+-\]integer?" + } + + # Concatenate the pre-insert, insertion, and post-insert strings. + string cat [string range $string 0 [expr {$index - 1}]] $insertString\ + [string range $string $index end] + } + + # Bind [string insert] to [::tcl::string::insert]. + tcl::namespace::ensemble configure string -map [tcl::dict::replace\ + [tcl::namespace::ensemble configure string -map]\ + insert ::tcl::string::insert] + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::lib { + variable PUNKARGS + tcl::namespace::export * + variable has_struct_list + set has_struct_list [expr {![catch {package require struct::list}]}] + variable has_struct_set + set has_struct_set [expr {![catch {package require struct::set}]}] + variable has_punk_ansi + set has_punk_ansi [expr {![catch {package require punk::ansi}]}] + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + + #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) + proc aliases {{glob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + set ns_mapped [string map {:: \uFFFF} $ns] + #puts stderr "aliases ns: $ns_mapped" + set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: + if {![string length [lindex $segments end]]} { + #special case for :: only include leading segment rather thatn {} {} + set segments [lrange $segments 0 end-1] + } + set segcount [llength $segments] ;#only match number of segments matching current ns + + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + + set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" + if {($acount - 1) == $segcount} { + if {[lrange $asegs 0 end-1] eq $segments} { + if {[string match $glob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + + return $matched + } + + proc alias {{aliasorglob ""} args} { + set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + if {[llength $args]} { + if {$aliasorglob in [interp aliases ""]} { + set existing [interp alias "" $aliasorglob] + puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" + } + if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { + #use empty string/whitespace as intention to delete alias + return [interp alias "" $aliasorglob ""] + } + return [interp alias "" $aliasorglob "" {*}$args] + } else { + if {![string length $aliasorglob]} { + set aliaslist [punk::lib::aliases] + puts -nonewline stderr $aliaslist + return + } + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias + set target [interp alias "" $aliasorglob] + if {[llength $target]} { + return $target + } + + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { + set aliaslist [punk::lib::aliases $aliasorglob] + puts -nonewline stderr $aliaslist + return + } + return [list] + } + } + + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + + # -- --- + #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists + #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 + #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows + # Review and retest as new versions come out. + # -- --- + proc list_multi_append1 {lvar1 lvar2} { + #clear winner in 2024 + upvar $lvar1 l1 $lvar2 l2 + lappend l1 {*}$l2 + return $l1 + } + proc list_multi_append2 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [list {*}$l1 {*}$l2] + } + proc list_multi_append3 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] + } + #testing e.g + #set l1_reset {a b c} + #set l2 {a b c d e f g} + #set l1 $l1_reset + #time {list_multi_append1 l1 l2} 1000 + #set l1 $l1_reset + #time {list_multi_append2 l1 l2} 1000 + # -- --- + + + proc lswap {lvar a z} { + upvar $lvar l + if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} { + #lindex_resolve_basic returns only -1 if out of range + #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred + #(e.g using: lswap mylist end-2 end on a two element list) + + #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report + #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) + set a_index [lindex_resolve $l $a] + set a_msg "" + switch -- $a_index { + -2 { + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + } + -3 { + set a_msg "1st supplied index $a is below the lower bound for the list (0)" + } + } + set z_index [lindex_resolve $l $z] + set z_msg "" + switch -- $z_index { + -2 { + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } + -3 { + set z_msg "2nd supplied index $z is below the lower bound for the list (0)" + } + } + set errmsg "lswap cannot swap indices $a and $z" + if {$a_msg ne ""} { + append errmsg \n $a_msg + } + if {$z_msg ne ""} { + append errmsg \n $z_msg + } + error $errmsg + } + set item2 [lindex $l $z] + lset l $z [lindex $l $a] + lset l $a $item2 + return $l + } + #proc lswap2 {lvar a z} { + # upvar $lvar l + # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] + #} + + proc lswap2 {lvar a z} { + upvar $lvar l + #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] + } + + #an experimental test of swapping vars without intermediate variables + #It's an interesting idea - but probably of little to no practical use + # - the swap_intvars3 version using intermediate var is faster in Tcl + # - This is probably unsurprising - as it's simpler code. + # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. + #proc swap_intvars {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] + #} + #proc swap_intvars2 {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {$_x ^ $_y}] + # set _y [expr {$_x ^ $_y}] + # set _x [expr {$_x ^ $_y}] + #} + #proc swap_intvars3 {swapv1 swapv2} { + # #using intermediate variable + # upvar $swapv1 _x $swapv2 _y + # set z $_x + # set _x $_y + # set _y $z + #} + + #*** !doctools + #[subsection {Namespace punk::lib}] + #[para] Core API functions for punk::lib + #[list_begin definitions] + + 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 + #support minimal set from to + proc range {from to} { + lseq $from $to + } + } else { + #lseq accepts basic expressions e.g 4-2 for both arguments + #e.g we can do lseq 0 [llength $list]-1 + #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. + proc range {from to} { + set to [offset_expr $to] + set from [offset_expr $from] + if {$to > $from} { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + #slower methods. + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from] + #} + #return $L + } elseif {$from > $to} { + set count [expr {$from - $to} + 1] + #1) + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from -1];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from -1] + #} + #return $L + } else { + return [list $from] + } + } + } + + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + return $zip_l + } + #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible + if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { + #-stride either not available - or has bug preventing use of main algorithm below + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + } else { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + + + namespace import ::punk::args::lib::tstr + + + + proc invoke command { + #*** !doctools + #[call [fun invoke] [arg command]] + #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode + #[example { + # set script { + # puts stdout {hello on stdout} + # puts stderr {hello on stderr} + # exit 42 + # } + # invoke [list tclsh <<$script] + #}] + + #see https://wiki.tcl-lang.org/page/open + lassign [chan pipe] chanout chanin + lappend command 2>@$chanin + set fh [open |$command] + set stdout [read $fh] + close $chanin + set stderr [read $chanout] + close $chanout + if {[catch {close $fh} cres e]} { + dict with e {} + lassign [set -errorcode] sysmsg pid exit + if {$sysmsg eq {NONE}} { + #output to stderr caused [close] to fail. Do nothing + } elseif {$sysmsg eq {CHILDSTATUS}} { + return [list $stdout $stderr $exit] + } else { + return -options $e $stderr + } + } + return [list $stdout $stderr 0] + } + + proc pdict {args} { + package require punk::args + variable has_punk_ansi + if {!$has_punk_ansi} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } + set argspec [string map [list %sep% $sep] { + @id -id ::punk::lib::pdict + @cmd -name pdict -help\ + "Print dict keys,values to channel + The pdict function operates on variable names - passing the value to the showdict function which operates on values + (see also showdict)" + + @opts -any 1 + + #default separator to provide similarity to tcl's parray function + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} + -channel -default stdout -help\ + "existing channel - or 'none' to return as string" + + @values -min 1 -max -1 + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + Segments are classified into list,dict and string operations. + Leading % indicates a string operation - e.g %# gives string length + A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 + A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' + The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. + e.g1 pdict env */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segement in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + } + }] + #puts stderr "$argspec" + set argd [punk::args::parse $args withdef $argspec] + + set opts [dict get $argd opts] + set dvar [dict get $argd values dictvar] + set patterns [dict get $argd values patterns] + set isarray [uplevel 1 [list array exists $dvar]] + if {$isarray} { + set dvalue [uplevel 1 [list array get $dvar]] + if {![dict exists $opts -keytemplates]} { + set arrdisplay [string map [list %dvar% $dvar] {${[if {[lindex $key 1] eq "query"} {val "%dvar% [lindex $key 0]"} {val "%dvar%($key)"}]}}] + dict set opts -keytemplates [list $arrdisplay] + } + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } + showdict {*}$opts $dvalue {*}$patterns + } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality + proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) + #set sep " [a+ Web-seagreen]=[a] " + variable has_punk_ansi + if {!$has_punk_ansi} { + set RST "" + set sep " = " + set sep_mismatch " mismatch " + } else { + set RST [punk::ansi::a] + set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " + } + package require punk::pipe + #package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + @id -id ::punk::lib::showdict + @cmd -name punk::lib::showdict -help "display dictionary keys and values" + #todo - table tableobject + -return -default "tailtohead" -choices {tailtohead sidebyside} + -channel -default none + -trimright -default 1 -type boolean -help\ + "Trim whitespace off rhs of each line. + This can help prevent a single long line that wraps in terminal from making + every line wrap due to long rhs padding." + -separator -default {%sep%} -help\ + "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help\ + "Separator to use when patterns mismatch" + -roottype -default "dict" -help\ + "list,dict,string" + -ansibase_keys -default "" -help\ + "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} + -ansibase_values -default "" + -keytemplates -default {\$\{$key\}} -type list -help\ + "list of templates for keys at each level" + -keysorttype -default "none" -choices {none dictionary ascii integer real} + -keysortdirection -default increasing -choices {increasing decreasing} + -debug -default 0 -type boolean -help\ + "When enabled, produces some rudimentary debug output on stderr" + @values -min 1 -max -1 + dictvalue -type list -help\ + "dict or list value" + patterns -default "*" -type string -multiple 1 -help\ + "key or key glob pattern" + }]] + + #for punk::lib - we want to reduce pkg dependencies. + # - so we won't even use the tcllib debug pkg here + set opt_debug [dict get $argd opts -debug] + if {$opt_debug} { + if {[info body debug::showdict] eq ""} { + proc ::punk::lib::debug::showdict {args} { + catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} + } + } + } else { + if {[info body debug::showdict] ne ""} { + proc ::punk::lib::debug::showdict {args} {} + } + } + + set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] + set opt_keysorttype [dict get $argd opts -keysorttype] + set opt_keysortdirection [dict get $argd opts -keysortdirection] + set opt_trimright [dict get $argd opts -trimright] + set opt_keytemplates [dict get $argd opts -keytemplates] + debug::showdict "keytemplates ---> $opt_keytemplates <---" + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] + set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] + + set dval [dict get $argd values dictvalue] + set patterns [dict get $argd values patterns] + + set result "" + + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set pattern_this_structure [dict create] + + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + + set filtered_keys [list] + if {$opt_roottype in {dict list string}} { + #puts "getting keys for roottype:$opt_roottype" + if {[llength $dval]} { + set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$} + set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + foreach pattern_nest $patterns { + set keyset [list] + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + if {[string index $p 0] eq "!"} { + set get_not 1 + set p [string range $p 1 end] + } else { + set get_not 0 + } + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string + } + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + #todo get_not !# is test for listiness (see punk) + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + #puts "showdict ---->@*<----" + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {$get_not} { + if {[dict exists $dval $k]} { + set keys [dict keys [dict remove $dval $k]] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + lappend keyset {*}[dict keys $dval] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + } + } else { + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + } + dict set pattern_this_structure $p dict + } + @k@* - @K@* { + #TODO get_not + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + #TODO get_not + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string + lappend keyset $p + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + if {$get_not} { + set keys [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $keys $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset $p + lappend keyset_structure list + } + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high + #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds + if {${lower_resolve} == -2} { + ##x + #lower bound is above upper list range + #match with decreasing indices is still possible + set lower [expr {[llength $dval]-1}] ;#set to max + } elseif {$lower_resolve == -3} { + ##x + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve $dval $b] + if {$upper == -3} { + ##x + #upper bound is below list range - + if {$lower_resolve >=-2} { + ##x + set upper 0 + } else { + continue + } + } elseif {$upper == -2} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + if {$get_not} { + set fullrange [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $fullrange {*}$keys] + if {$lower > $upper} { + set keys [lreverse $keys] + } + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + if {$get_not} { + lappend keyset [list !@$p query] + } else { + lappend keyset [list @$p query] + } + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + if {$get_not} { + set keys [dict keys [dict remove $dval {*}$keys]] + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + } + } + } + } + + # -- --- --- --- + #check next pattern-segment for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $segments 1] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + #ignore the NOT operator for purposes of query-type detection + if {[string index $pnext 0] eq "!"} { + set pnext [string range $pnext 1 end] + } + # single type in segment e.g /@@something/ + switch -exact $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + } + } + } + } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + if {$opt_keysorttype ne "none"} { + set int_keyset 1 + foreach k $keyset { + if {![string is integer -strict $k]} { + set int_keyset 0 + break + } + } + if {$int_keyset} { + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] + } else { + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] + } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] + } + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + + lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure + + #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" + } + } + #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" + } else { + puts stdout "unrecognised roottype: $opt_roottype" + return $dval + } + + if {[llength $filtered_keys]} { + #both keys and values could have newline characters. + #simple use of 'format' won't cut it for more complex dict keys/values + #use block::width or our columns won't align in some cases + switch -- $opt_return { + "tailtohead" { + #last line of key is side by side (possibly with separator) with first line of value + #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values + #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt {${$key}} + } + #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + set last_hidekey 0 + foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" + set hidekey 0 + set pattern_nest [lindex $pattern_key_index $kidx] + set pattern_nest_list [split $pattern_nest /] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" + + set is_match 1 ;#whether to display the normal separator or bad-match separator + switch -- $this_type { + dict { + #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + % thisval.= $qry= $dval + } else { + set thisval [tcl::dict::get $dval $key] + } + + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" + set is_match 0 + } + } + } + list { + if {[string is integer -strict $key]} { + set thisval [lindex $dval $key] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + % thisval.= $qry= $dval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + #if {![llength $nextpatterns]} { + # set nextpatterns * + #} + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + set is_match 0 + } + } + } + string { + set hidekey 1 + if {$key eq "%string"} { + set hidekey 1 + set thisval $dval + } elseif {$key eq "%ansiview"} { + set thisval [ansistring VIEW -lf 1 $dval] + } elseif {$key eq "%ansiviewstyle"} { + set thisval [ansistring VIEWSTYLE -lf 1 $dval] + } elseif {[string match *lpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] + } elseif {[string match *rpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + set thisval $dval + if {[string index $key 0] ne "%"} { + set key %$key + } + % thisval.= $key= $thisval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + #set nextopts [dict get $argd opts] + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + if {[llength $nextpatterns]} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } + } + if {$this_type eq "string" && $hidekey} { + lassign [textblock::size $thisval] _vw vwidth _vh vheight + #set blanks_above [string repeat \n [expr {$kheight -1}]] + set vblock $opt_ansibase_values$thisval$RST + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" + } else { + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + + set totalheight [expr {$kheight + $vheight -1}] + set blanks_above [string repeat \n [expr {$kheight -1}]] + set blanks_below [string repeat \n [expr {$vheight -1}]] + + if {$is_match} { + set use_sep $opt_sep + } else { + set use_sep $opt_mismatch_sep + } + + + set sepwidth [textblock::width $use_sep] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] + set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] + set vblock $blanks_above$opt_ansibase_values$thisval$RST + #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } + append result [textblock::join_basic -- $kblock $sblock $vblock] \n + } + set last_hidekey $hidekey + incr kidx + } + } + "sidebyside" { + # TODO - fix + #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. + #use ansibase_key etc to make the output more comprehensible in that situation. + #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] + foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST + #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n + #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n + } + } + } + } + if {$opt_trimright} { + set result [::join [lines_as_list -line trimright $result] \n] + } + if {[string last \n $result] == [string length $result]-1} { + set result [string range $result 0 end-1] + } + #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) + set chan [dict get $argd opts -channel] + switch -- $chan { + stderr - stdout { + puts $chan $result + } + none { + return $result + } + default { + #review - check member of chan names? + #just try outputting to the supplied channel for now + puts $chan $result + } + } + } + + proc is_list_all_in_list {small large} { + set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] + return [struct::list equal [lsort $small] $small_in_large] + } + if {!$has_struct_list || !$has_struct_set} { + set body { + package require struct::list + package require struct::set + } + append body [info body is_list_all_in_list] + proc is_list_all_in_list {small large} $body + } + + proc is_list_all_ni_list {a b} { + set i [struct::set intersect $a $b] + return [expr {[llength $i] == 0}] + } + if {!$has_struct_set} { + set body { + package require struct::list + } + append body [info body is_list_all_ni_list] + proc is_list_all_ni_list {a b} $body + } + + #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist + #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, + # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) + proc ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + proc ldiff2 {fromlist removeitems} { + set doomed [list] + foreach item $removeitems { + lappend doomed {*}[lsearch -all -exact $fromlist $item] + } + lremove $fromlist {*}$doomed + } + + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) + #also struct::set difference with critcl is faster + proc setdiff {A B} { + if {[llength $A] == 0} {return {}} + set d [dict create] + foreach x $A {dict set d $x {}} + foreach x $B {dict unset d $x} + return [dict keys $d] + } + #bulk dict remove is slower than a foreach with dict unset + #proc setdiff2 {fromlist removeitems} { + # #if {[llength $fromlist] == 0} {return {}} + # set d [dict create] + # foreach x $fromlist { + # dict set d $x {} + # } + # return [dict keys [dict remove $d {*}$removeitems]] + #} + #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) + proc setdiff_unordered {A B} { + if {[llength $A] == 0} {return {}} + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] + } + + #default/fallback implementation + proc lunique_unordered {list} { + lunique $list + } + if {$has_struct_set} { + if {[struct::set equal [struct::set union {a a} {}] {a}]} { + proc lunique_unordered {list} { + struct::set union $list {} + } + } else { + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add + } + } + + + #order-preserving + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + proc lunique2 {list} { + set doomed [list] + #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) + for {set i 0} {$i < [llength $list]} {} { + set item [lindex $list $i] + lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] + while {[incr i] in $doomed} {} + } + lremove $list {*}$doomed + } + #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env + proc lmapflat_closure {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + # -- --- --- + #capture - use uplevel 1 or namespace eval depending on context + set capture [uplevel 1 { + apply { varnames { + set capturevars [tcl::dict::create] + set capturearrs [tcl::dict::create] + foreach fullv $varnames { + set v [tcl::namespace::tail $fullv] + upvar 1 $v var + if {[info exists var]} { + if {(![array exists var])} { + tcl::dict::set capturevars $v $var + } else { + tcl::dict::set capturearrs capturedarray_$v [array get var] + } + } else { + #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set + } + } + return [tcl::dict::create vars $capturevars arrs $capturearrs] + } } [info vars] + } ] + # -- --- --- + set cvars [tcl::dict::get $capture vars] + set carrs [tcl::dict::get $capture arrs] + set apply_script "" + foreach arrayalias [tcl::dict::keys $carrs] { + set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { + array set %realname% [set %arrayalias%][unset %arrayalias%] + }] + } + + append apply_script [string map [list %script% $script] { + #foreach arrayalias [info vars capturedarray_*] { + # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + # array set $realname [set $arrayalias][unset arrayalias] + #} + #return [eval %script%] + %script% + }] + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ + $apply_script\ + ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] + } + return $result + } + #link version - can write to vars in calling context - but keeps varnames themselves isolated + #performance much better than capture version - but still a big price to pay for the isolation + proc lmapflat_link {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + #proc lmapflat {varnames list script} { + # concat {*}[uplevel 1 [list lmap $varnames $list $script]] + #} + #lmap can accept multiple var list pairs + proc lmapflat {args} { + concat {*}[uplevel 1 [list lmap {*}$args]] + } + proc lmapflat2 {args} { + concat {*}[uplevel 1 lmap {*}$args] + } + + #proc dict_getdef {dictValue args} { + # if {[llength $args] < 1} { + # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} + # } + # set keys [lrange $args -1 end-1] + # if {[tcl::dict::exists $dictValue {*}$keys]} { + # return [tcl::dict::get $dictValue {*}$keys] + # } else { + # return [lindex $args end] + # } + #} + 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::lib::dict_getdef "" ::tcl::dict::getdef + } + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side + proc lindex_resolve {list index} { + #*** !doctools + #[call [fun lindex_resolve] [arg list] [arg index]] + #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list + #[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl. + #[para]This means the proc may be called with something like $x+2 end-$y etc + #[para]Sometimes the actual integer index is desired. + #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. + #[para]lindex_resolve will parse the index expression and return: + #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) + #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) + #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list + #[para]Otherwise it will return an integer corresponding to the position in the list. + #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. + #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable + #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 + + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr + #if {![llength $list]} { + # #review + # return ??? + #} + set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + if {$index < 0} { + return -3 + } elseif {$index >= [llength $list]} { + return -2 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$op eq "+" && $offset != 0} { + return -2 + } + } else { + #index is 'end' + set index [expr {[llength $list]-1}] + if {$index < 0} { + #special case - 'end' with empty list - treat end like a positive number out of bounds + return -2 + } else { + return $index + } + } + if {$offset == 0} { + set index [expr {[llength $list]-1}] + if {$index < 0} { + return -2 ;#special case as above + } else { + return $index + } + } else { + #by now, if op = + then offset = 0 so we only need to handle the minus case + set index [expr {([llength $list]-1) - $offset}] + } + if {$index < 0} { + return -3 + } else { + return $index + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < 0} { + return -3 + } elseif {$index >= [llength $list]} { + return -2 + } + return $index + } + } + } + proc lindex_resolve_basic {list index} { + #*** !doctools + #[call [fun lindex_resolve_basic] [arg list] [arg index]] + #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) + #[para] returns -1 for out of range at either end, or a valid integer index + #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound + #[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command + #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 + #[para] For pure integer indices the performance should be equivalent + + #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ + # - which + #for {set i 0} {$i < [llength $list]} {incr i} { + # lappend indices $i + #} + set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + #avoid even the lseq overhead when the index is simple + if {$index < 0 || ($index >= [llength $list])} { + #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. + return -1 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } + if {[llength $list]} { + set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + } else { + set indices [list] + } + set idx [lindex $indices $index] + if {$idx eq ""} { + #we have no way to determine if out of bounds is at lower vs upper end + return -1 + } else { + return $idx + } + } + proc lindex_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [tcl::dict::create value [lindex $resultlist 0]] + } + } + + + proc K {x y} {return $x} + #*** !doctools + #[call [fun K] [arg x] [arg y]] + #[para]The K-combinator function - returns the first argument, x and discards y + #[para]see [uri https://wiki.tcl-lang.org/page/K] + #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + + + proc is_utf8_multibyteprefix {bytes} { + #*** !doctools + #[call [fun is_utf8_multibyteprefix] [arg str]] + #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character + #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint + #[para] Will return false for an already complete utf-8 codepoint + #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument + #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes + #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] + regexp {(?x) + ^ + (?: + [\xC0-\xDF] | #possible prefix for two-byte codepoint + [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for + ) + $ + } $bytes + } + + proc is_utf8_first {str} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + } $str + } + proc is_utf8_single {1234bytes} { + #*** !doctools + #[call [fun is_utf8_single] [arg 1234bytes]] + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + $ + } $1234bytes + } + proc get_utf8_leading {rawbytes} { + #*** !doctools + #[call [fun get_utf8_leading] [arg rawbytes]] + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint + #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. + #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. + #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics + #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned + #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes + if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $rawbytes completeChars]} { + return $completeChars + } + return "" + } + proc hex2dec {args} { + #*** !doctools + #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] + #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values + #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 + #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. + #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 + #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 + + set list_largeHex [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" + } + set opts [tcl::dict::create\ + -validate 1\ + -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $opts] + foreach {k v} $argopts { + tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v + } + # -- --- --- --- + set opt_validate [tcl::dict::get $opts -validate] + set opt_empty [tcl::dict::get $opts -empty_as_hex] + # -- --- --- --- + + set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] + if {$opt_validate} { + #Note appended F so that we accept list of empty strings as per the documentation + if {![string is xdigit -strict [join $list_largeHex ""]F ]} { + error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" + } + } + if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { + #mapping empty string to a value destroys any advantage of -scanonly + #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] + if {[lsearch $list_largeHex ""] >=0} { + error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" + } + } else { + set opt_empty [string trim [string map {_ ""} $opt_empty]] + if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] + set nonempty_head [lrange $list_largeHex 0 $first_empty-1] + set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] + } + + proc dec2hex {args} { + #*** !doctools + #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] + #[para]Convert a list of decimal integers to a list of hex values + #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. + #[para] -case upper|lower determines the case of the hex letters in the output + set list_decimals [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" + } + set defaults [tcl::dict::create\ + -width 1\ + -case upper\ + -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $defaults] + set fullopts [tcl::dict::create] + foreach {k v} $argopts { + tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v + } + set opts [tcl::dict::merge $defaults $fullopts] + # -- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_case [tcl::dict::get $opts -case] + set opt_empty [tcl::dict::get $opts -empty_as_decimal] + # -- --- --- --- + + + set resultlist [list] + switch -- [string tolower $opt_case] { + upper { + set spec X + } + lower { + set spec x + } + default { + error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" + } + } + set fmt "%${opt_width}.${opt_width}ll${spec}" + + set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] + if {![string is digit -strict [string map {_ ""} $opt_empty]]} { + if {[lsearch $list_decimals ""] >=0} { + error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" + } + } else { + set opt_empty [string map {_ ""} $opt_empty] + if {[set first_empty [lsearch $list_decimals ""]] >= 0} { + set nonempty_head [lrange $list_decimals 0 $first_empty-1] + set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] + } + + proc log2 x "expr {log(\$x)/[expr log(2)]}" + #*** !doctools + #[call [fun log2] [arg x]] + #[para]log base2 of x + #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time + #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) + + proc logbase {b x} { + #*** !doctools + #[call [fun logbase] [arg b] [arg x]] + #[para]log base b of x + #[para]This function uses expr's natural log and the change of base division. + #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 + expr {log($x)/log($b)} + } + proc factors {x} { + #*** !doctools + #[call [fun factors] [arg x]] + #[para]Return a sorted list of the positive factors of x where x > 0 + #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* + #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors + #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + #[para]Comparisons were done with some numbers below 17 digits long + #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers + #but has the disadvantage of being slower for 'small' numbers and using more memory. + #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x + #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + #[para] In other mathematical contexts zero may be considered not to divide anything. + set factors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {($x % $j) == 0} { + lappend factors $j [expr {$x / $j}] + } + incr j + } + lappend factors $x + return [lsort -unique -integer $factors] + } + proc oddFactors {x} { + #*** !doctools + #[call [fun oddFactors] [arg x]] + #[para]Return a list of odd integer factors of x, sorted in ascending order + set j 2 + set max [expr {sqrt($x)}] + set factors [list 1] + while {$j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2} { + if {$other ni $factors} { + lappend factors $other + } + } + if {$j % 2} { + if {$j ni $factors} { + lappend factors $j + } + } + } + incr j + } + return [lsort -integer -increasing $factors] + } + proc greatestFactorBelow {x} { + #*** !doctools + #[call [fun greatestFactorBelow] [arg x]] + #[para]Return the largest factor of x excluding itself + #[para]factor functions can be useful for console layout calculations + #[para]See Tcllib math::numtheory for more extensive implementations + if {$x % 2 == 0 || $x == 0} { + return [expr {$x / 2}] + } + set j 3 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {$x % $j == 0} { + return [expr {$x / $j}] + } + incr j 2 + } + return 1 + } + proc greatestOddFactorBelow {x} { + #*** !doctools + #[call [fun greatestOddFactorBelow] [arg x]] + #[para]Return the largest odd integer factor of x excluding x itself + if {$x %2 == 0} { + return [greatestOddFactor $x] + } + set j 3 + #dumb brute force - time taken to compute is wildly variable on big numbers + #todo - use a (memoized?) generator of primes to reduce the search space + #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. + set god 1 + set max [expr {sqrt($x)}] + while { $j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2 == 0} { + set god $j + } else { + set god [expr {$x / $j}] + #lowest j - so other side must be highest + break + } + } + incr j 2 + } + return $god + } + proc greatestOddFactor {x} { + #*** !doctools + #[call [fun greatestOddFactor] [arg x]] + #[para]Return the largest odd integer factor of x + #[para]For an odd value of x - this will always return x + if {$x % 2 != 0 || $x == 0} { + return $x + } + set r [expr {$x / 2}] + while {$r % 2 == 0} { + set r [expr {$r / 2}] + } + return $r + } + proc gcd {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the greatest common divisor of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para]Graphical use: + #[para]An a by b rectangle can be covered with square tiles of side-length c, + #[para]only if c is a common divisor of a and b + + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m + } + proc lcm {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the lowest common multiple of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para] + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] + } + proc commonDivisors {x y} { + #*** !doctools + #[call [fun commonDivisors] [arg x] [arg y]] + #[para]Return a list of all the common factors of x and y + #[para](equivalent to factors of their gcd) + return [factors [gcd $x $y]] + } + + #experimental only - there are better/faster ways + proc sieve n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + tcl::dict::for {next -} $nums break + } + return [concat $primes [tcl::dict::keys $nums]] + } + proc sieve2 n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + #dict for {next -} $nums break + set next [lindex $nums 0] + } + return [concat $primes [tcl::dict::keys $nums]] + } + + proc hasglobs {str} { + #*** !doctools + #[call [fun hasglobs] [arg str]] + #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] + #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. + regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving + } + + proc trimzero {number} { + #*** !doctools + #[call [fun trimzero] [arg number]] + #[para]Return number with left-hand-side zeros trimmed off - unless all zero + #[para]If number is all zero - a single 0 is returned + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + proc substring_count {str substring} { + #*** !doctools + #[call [fun substring_count] [arg str] [arg substring]] + #[para]Search str and return number of occurrences of substring + + #faster than lsearch on split for str of a few K + if {$substring eq ""} {return 0} + set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] + return [expr {$occurrences / [string length $substring]}] + } + + proc dict_merge_ordered {defaults main} { + #*** !doctools + #[call [fun dict_merge_ordered] [arg defaults] [arg main]] + #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. + #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. + #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. + + #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] + } + + proc askuser {question} { + #*** !doctools + #[call [fun askuser] [arg question]] + #[para]A basic utility to read an answer from stdin + #[para]The prompt is written to the terminal and then it waits for a user to type something + #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. + #[para](Generic terminal raw vs linemode detection not yet present) + #[para]The user must hit enter to submit the response + #[para]The return value is the string if any that was typed prior to hitting enter. + #[para]The question argument can be manually colourised using the various punk::ansi funcitons + #[example_begin] + # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] + # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { + # puts "Proceeding" + # } else { + # puts "Cancelled by user" + # } + #[example_end] + puts stdout $question + flush stdout + set stdin_state [chan configure stdin] + if {[catch { + package require punk::console + set console_raw [tsv::get console is_raw] + } err_console]} { + #assume normal line mode + set console_raw 0 + } + try { + chan configure stdin -blocking 1 + if {$console_raw} { + punk::console::disableRaw + set answer [gets stdin] + punk::console::enableRaw + } else { + set answer [gets stdin] + } + } finally { + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] + } + return $answer + } + + #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] + } + #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 + } + + #e.g linesort -decreasing $data + proc linesort {args} { + #*** !doctools + #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] + #[para]Sort lines in textblock + #[para]Returns another textblock with lines sorted + #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique + if {[llength $args] < 1} { + error "linesort missing lines argument" + } + set lines [lindex $args end] + set opts [lrange $args 0 end-1] + #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts + list_as_lines [lsort {*}$opts [linelist $lines]] + } + + proc list_as_lines {args} { + #*** !doctools + #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] + #[para]This simply joins the elements of the list with -joinchar + #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines + #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. + if {[set eop [lsearch $args --]] == [llength $args]-2} { + #end-of-opts not really necessary - except for consistency with lines_as_list + set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] + } + if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { + set joinchar [lindex $args 1] + set lines [lindex $args 2] + } elseif {[llength $args] == 1} { + set joinchar "\n" + set lines [lindex $args 0] + } else { + error "list_as_lines usage: list_as_lines ?-joinchar ? " + } + return [join $lines $joinchar] + } + proc list_as_lines2 {args} { + #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? + lassign [tcl::dict::values [punk::args::parse $args withdef { + -joinchar -default \n + @values -min 1 -max 1 + }]] leaders opts values + + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + } + + proc lines_as_list {args} { + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. + #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error + #..because we don't know what to say if there are odd numbers of args + #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work + #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway + + if {[lsearch $args "--"] == [llength $args]-2} { + set opts [lrange $args 0 end-2] + } else { + set opts [lrange $args 0 end-1] + } + #set opts [tcl::dict::merge {-block {}} $opts] + set bposn [lsearch $opts -block] + if {$bposn < 0} { + lappend opts -block {} + } + set text [lindex $args end] + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] + } + #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds + proc lines_as_list2 {args} { + #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults + #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc + #we don't have to decide what is an opt vs a value + #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) + lassign [tcl::dict::values [punk::args::parse $args withdef { + @opts -any 1 + -block -default {} + }]] leaderdict opts valuedict + tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] + } + + # important for pipeline & match_assign + # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? + # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace + set linelist_body { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach code $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + #not sure if this handles more complex hierarchies or mixins etc. + lassign $args obj method + if {![info object isa object $obj]} { + error "show_jump_tables unable to examine '$args'. $obj is not an oo object" + } + #classes are objects too and can have direct methods + if {$method in [info object methods $obj]} { + set data [tcl::unsupported::disassemble objmethod $obj $method] + } else { + if {![info object isa class $obj]} { + set obj [info object class $obj] + } + set data [tcl::unsupported::disassemble method $obj $method] + } + } else { + error "show_jump_tables expected a procname or a class/object and method" + } + set result "" + set in_jt 0 + foreach ln [split $data \n] { + set tln [string trim $ln] + if {!$in_jt} { + if {[string match *jumpTable* $ln]} { + append result $ln \n + set in_jt 1 + } + } else { + if {[string match Command* $tln] || [string match "(*) *" $tln]} { + set in_jt 0 + } else { + append result $ln \n + } + } + } + return $result + } + + proc temperature_f_to_c {deg_fahrenheit} { + return [expr {($deg_fahrenheit -32) * (5/9.0)}] + } + proc temperature_c_to_f {deg_celsius} { + return [expr {($deg_celsius * (9/5.0)) + 32}] + } + + proc interp_sync_package_paths {interp} { + if {![interp exists $interp]} { + error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" + } + interp eval $interp [list set ::auto_path $::auto_path] + interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} + interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] + } + + proc objclone {obj} { + append obj2 $obj {} + } + proc set_clone {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + + + proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { + variable has_twapi + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + } + } + #when using twapi we currently only get the localeid - not the specific defaults + #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this + set default_delim "," + set default_groupsize 3 + + set results [list] + set nums [objclone $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + foreach inputnum $nums { + set number [objclone $inputnum] + #also handle tcl 8.7+ underscores in numbers + set number [string map [list _ "" , ""] $number] + #normalize e.g 2e4 -> 20000.0 + set number [expr {$number}] + + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + lappend results [twapi::format_number $number $localeid -idigits -1] + continue + } else { + #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one + #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? + if {$delim eq ""} {set delim $default_delim} + if {$groupsize eq ""} {set groupsize $default_groupsize} + lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + continue + } + } + #todo - get configured user defaults + if {$delim eq ""} { + set delim $default_delim + } + if {$groupsize eq ""} { + set groupsize $default_groupsize + } + + lappend results [delimit_number $number $delim $groupsize] + } + + if {[llength $results] == 1} { + #keep intrep as string rather than list + return [lindex $results 0] + } + return $results + } + + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { + set number [objclone $unformattednumber] + set number [string map {_ ""} $number] + #normalize using expr - e.g 2e4 -> 20000.0 + set number [expr {$number}] + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number $point+1 end]; + set PostDecimalP 1; + } else { + set point [expr {[string length $number] + 1}] + set PostDecimal ""; + set PostDecimalP 0; + } + + # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr {$FirstNonSpace - 1}]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace $point-1]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize + } + + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} + +tcl::namespace::eval punk::lib::test { + + + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#todo - way to generate 'internal' docs separately? +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::lib::system { + #*** !doctools + #[subsection {Namespace punk::lib::system}] + #[para] Internal functions that are not part of the API + #[list_begin definitions] + + + proc mostFactorsBelow {n} { + ##*** !doctools + #[call [fun mostFactorsBelow] [arg n]] + #[para]Find the number below $n which has the greatest number of factors + #[para]This will get slow quickly as n increases (100K = 1s+ 2024) + set most 0 + set mostcount 0 + for {set i 1} {$i < $n} {incr i} { + set fc [llength [punk::lib::factors $i]] + if {$fc > $mostcount} { + set most $i + set mostcount $fc + } + } + return [list number $most numfactors $mostcount] + } + proc factorCountBelow_punk {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [punk::lib::factors $i]] + } + return $tally + } + proc factorCountBelow_numtheory {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) + package require math::numtheory + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [math::numtheory::factors $i]] + } + return $tally + } + + proc factors2 {x} { + ##*** !doctools + #[call [fun factors2] [arg x]] + #[para]Return a sorted list of factors of x + #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. + set smallfactors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j < $max} { + if {($x % $j) == 0} { + lappend smallfactors $j + lappend largefactors [expr {$x / $j}] + } + incr j + } + #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop + if {($x % $j) == 0} { + if {$j == ($x / $j)} { + lappend smallfactors $j + } + } + return [concat $smallfactors [lreverse $largefactors] $x] + } + + + + # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + set i 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + incr i + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) + switch -- $c { + {"} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } + {[} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "{" { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "}" - + default { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + incr i + } + set incomplete [list] + foreach w $waiting { + #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. + switch -- $w { + {"} { + lappend incomplete $w + } + {]} { + lappend incomplete "\[" + } + "{" {} + "}" { + lappend incomplete "\{" + } + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->awaiting:'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + + #get info about punk nestindex key ie type: list,dict,undetermined + # pdict devel + proc nestindex_info {args} { + set argd [punk::args::parse $args withdef { + -parent -default "" + nestindex + }] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + #??? + + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] +} + +tcl::namespace::eval punk::lib::debug { + proc showdict {args} {} +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::lib +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::lib [tcl::namespace::eval punk::lib { + variable pkg punk::lib + variable version + set version 0.1.2 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm new file mode 100644 index 00000000..6f01e340 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -0,0 +1,1061 @@ +# -*- tcl -*- +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::libunknown 0.1 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::libunknown 0.1] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::libunknown] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::libunknown +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::libunknown +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + + +tcl::namespace::eval punk::libunknown { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace punk::libunknown}] + #[para] Core API functions for punk::libunknown + #[list_begin definitions] + + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + lappend PUNKARGS [list { + @id -id "(package)punk::libunknown" + @package -name "punk::libunknown" -help\ + "Experimental set of replacements for default 'package unknown' entries." + }] + + variable epoch + if {![info exists epoch]} { + set tmstate [dict create 0 {}] + set pkgstate [dict create 0 {}] + set tminfo [dict create current 0 epochs $tmstate] + set pkginfo [dict create current 0 epochs $pkgstate] + + set epoch [dict create tm $tminfo pkg $pkginfo] + } + + variable has_package_files + if {[catch {package files foobaz}]} { + set has_package_files 0 + } else { + set has_package_files 1 + } + + if {[info commands ::tcl::Pkg::source] ne ""} { + interp alias "" ::punk::libunknown::tcl_Pkg_source "" ::tcl::Pkg::source + } else { + #early 8.6 - pre tip459? + #we don't have + #::source -nopkg + proc tcl_Pkg_source {filename} { + uplevel 1 [list ::source $filename] + } + } + + #will use standard mechanism for non zipfs paths in the tm list. + proc zipfs_tm_UnknownHandler {original name args} { + # Import the list of paths to search for packages in module form. + # Import the pattern used to check package names in detail. + variable epoch + set pkg_epoch [dict get $epoch tm current] + + + #variable paths + upvar ::tcl::tm::paths paths + #variable pkgpattern + upvar ::tcl::tm::pkgpattern pkgpattern + + # Without paths to search we can do nothing. (Except falling back to the + # regular search). + set tid [format %-19s -] + catch {set tid [thread::id]} + + if {[llength $paths]} { + set pkgpath [string map {:: /} $name] + set pkgroot [file dirname $pkgpath] + if {$pkgroot eq "."} { + set pkgroot "" + } + + # We don't remember a copy of the paths while looping. Tcl Modules are + # unable to change the list while we are searching for them. This also + # simplifies the loop, as we cannot get additional directories while + # iterating over the list. A simple foreach is sufficient. + + if {[info commands ::tcl::zipfs::root] ne ""} { + set zipfsroot [tcl::zipfs::root] + set has_zipfs 1 + } else { + set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands + set has_zipfs 0 + } + + set satisfied 0 + foreach path $paths { + if {![interp issafe] && ![file exists $path]} { + continue + } + set currentsearchpath [file join $path $pkgroot] + + # Get the module files out of the subdirectories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. + + set use_epoch_for_all 1 + if {$use_epoch_for_all || [string match $zipfsroot* $path]} { + if {[dict exists $epoch tm epochs $pkg_epoch indexes $currentsearchpath]} { + #indexes are actual .tm files here + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles ( cached ): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" + } else { + + if {![interp issafe] && ![file exists $currentsearchpath]} { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + continue + } + + + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath [dict create] + + # ################################################################# + if {$has_zipfs && [string match $zipfsroot* $path]} { + set tmfiles [::tcl::zipfs::list $currentsearchpath/*.tm] ;#could theoretically be a dir - this is effectively a tree traversal + foreach tm_path $tmfiles { + dict set epoch tm epochs $pkg_epoch indexes [file dirname $tm_path] $tm_path $pkg_epoch + } + #retrieval using tcl::zipfs::list got (and cached) extras - limit to currentsearchpath + set tmfiles [dict keys [dict get $epoch tm epochs $pkg_epoch indexes $currentsearchpath]] + } else { + set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] + foreach tm_path $tmfiles { + dict set epoch tm epochs $pkg_epoch indexes $currentsearchpath $tm_path $pkg_epoch + } + } + #puts "--->zipfs_tm_UnknownHandler $tid llength tmfiles (UNcached): [format %4d [llength $tmfiles]] name:$name searchpath:$currentsearchpath" + + # ################################################################# + } + if {![llength $tmfiles]} { + continue + } + + # like normal processing - but track added (for static zipfs) + + set can_skip_update 0 + if {[string match $zipfsroot* $path]} { + #static tm location + if {[dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath]} { + if {![dict exists $epoch tm epochs $pkg_epoch added $currentsearchpath $name]} { + #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. + #puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP orig:$original name:$name args:$args searchpath:$currentsearchpath" + set can_skip_update 1 + } else { + #if this name is in 'added' then we must have done something like a package forget or it wouldn't come back to package unknown + #dict unset epoch tm epochs $pkg_epoch added $currentsearchpath $name + } + } + } else { + #dynamic - can only skip if negatively cached for the current epoch + if {[dict exists $epoch tm epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tm_UnknownHandler $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_update 1 + } + + } + + if {!$can_skip_update} { + set strip [llength [file split $path]] + set found_name_in_currentsearchpath 0 ;#for negative cache by epoch + catch { + foreach file $tmfiles { + set pkgfilename [join [lrange [file split $file] $strip end] ::] + + if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { + # Ignore everything not matching our pattern for + # package names. + continue + } + try { + package vcompare $pkgversion 0 + } on error {} { + # Ignore everything where the version part is not + # acceptable to "package vcompare". + continue + } + + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. + continue + } + + # We have found a candidate, generate a "provide script" + # for it, and remember it. Note that we are using ::list + # to do this; locally [list] means something else without + # the namespace specifier. + + # NOTE. When making changes to the format of the provide + # command generated below CHECK that the 'LOCATE' + # procedure in core file 'platform/shell.tcl' still + # understands it, or, if not, update its implementation + # appropriately. + # + # Right now LOCATE's implementation assumes that the path + # of the package file is the last element in the list. + + package ifneeded $pkgname $pkgversion \ + "[::list package provide $pkgname $pkgversion];[::list source $file]" + + #JMN + #store only once for each name, although there may be multiple versions + dict set epoch tm epochs $pkg_epoch added $currentsearchpath $pkgname $pkg_epoch + + # We abort in this unknown handler only if we got a + # satisfying candidate for the requested package. + # Otherwise we still have to fallback to the regular + # package search to complete the processing. + + if {($pkgname eq $name) + && [package vsatisfies $pkgversion {*}$args]} { + set satisfied 1 + + # We do not abort the loop, and keep adding provide + # scripts for every candidate in the directory, just + # remember to not fall back to the regular search + # anymore. + #(obsolete for libunknown - review) + } + + if {$pkgname eq $name} { + #can occur multiple times, different versions + #record package name as found in this path whether version satisfies or not + set found_name_in_currentsearchpath 1 + } + } + } + if {!$found_name_in_currentsearchpath} { + #can record as unfound for this path - for this epoch + dict set epoch tm epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + } + + } else { + #non zipfs tm path - normal processing + # We always look for _all_ possible modules in the current + # path, to get the max result out of the glob. + set tmfiles [glob -nocomplain -directory $currentsearchpath *.tm] + set strip [llength [file split $path]] + catch { + foreach file $tmfiles { + set pkgfilename [join [lrange [file split $file] $strip end] ::] + + if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { + # Ignore everything not matching our pattern for + # package names. + continue + } + try { + package vcompare $pkgversion 0 + } on error {} { + # Ignore everything where the version part is not + # acceptable to "package vcompare". + continue + } + + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. + continue + } + + # We have found a candidate, generate a "provide script" + # for it, and remember it. Note that we are using ::list + # to do this; locally [list] means something else without + # the namespace specifier. + + # NOTE. When making changes to the format of the provide + # command generated below CHECK that the 'LOCATE' + # procedure in core file 'platform/shell.tcl' still + # understands it, or, if not, update its implementation + # appropriately. + # + # Right now LOCATE's implementation assumes that the path + # of the package file is the last element in the list. + + package ifneeded $pkgname $pkgversion \ + "[::list package provide $pkgname $pkgversion];[::list source $file]" + + # We abort in this unknown handler only if we got a + # satisfying candidate for the requested package. + # Otherwise we still have to fallback to the regular + # package search to complete the processing. + + if {($pkgname eq $name) + && [package vsatisfies $pkgversion {*}$args]} { + set satisfied 1 + + # We do not abort the loop, and keep adding provide + # scripts for every candidate in the directory, just + # remember to not fall back to the regular search + # anymore. + } + } + } + + } + ##ZZZ + + } + + if {$satisfied} { + ##return + } + } + + # Fallback to previous command, if existing. See comment above about + # ::list... + + if {[llength $original]} { + #puts "zipfs_tm_UnknownHandler passing on to: $original [::linsert $args 0 $name]" + uplevel 1 $original [::linsert $args 0 $name] + } + } + proc zipfs_tclPkgUnknown {name args} { + #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" + + variable epoch + set pkg_epoch [dict get $epoch pkg current] + + + #global auto_path env + global auto_path + + if {![info exists auto_path]} { + return + } + + set tid [format %-19s -] + catch {set tid [thread::id]} + + if {[info commands ::tcl::zipfs::root] ne ""} { + set zipfsroot [tcl::zipfs::root] + set has_zipfs 1 + } else { + set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands + set has_zipfs 0 + } + + + #review - think about this + #typical dict size might be 800 packages - values are versions + #we probably don't need to create/destroy it for each iteration of the wile. + #question is whether some pkgIndex.tcl files may do a package forget? They probably don't/shouldn't(?) Does that matter here anyway? + set before_dict [dict create] + + + # Cache the auto_path, because it may change while we run through the + # first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + + # Make sure we only scan each directory one time. + if {[info exists tclSeenPath($dir)]} { + set use_path [lrange $use_path 0 end-1] + continue + } + set tclSeenPath($dir) 1 + + # Get the pkgIndex.tcl files in subdirectories of auto_path directories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. + + set use_epoch_for_all 1 + if {$use_epoch_for_all || [string match $zipfsroot* $dir]} { + set currentsearchpath $dir + if {[dict exists $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]} { + set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]] + #puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles ( cached ): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" + } else { + dict set epoch pkg epochs $pkg_epoch indexes $currentsearchpath [dict create] + # ################################################################# + set indexpaths [glob -directory $currentsearchpath -join -nocomplain * pkgIndex.tcl] + foreach idxpath $indexpaths { + dict set epoch pkg epochs $pkg_epoch indexes $currentsearchpath $idxpath 1 + } + set indexfiles [dict keys [dict get $epoch pkg epochs $pkg_epoch indexes $currentsearchpath]] + #puts stderr "--->zipfs_tclPkgUnknown $tid llength tmfiles (UNcached): [format %4d [llength $indexfiles]] name:$name searchpath:$currentsearchpath" + # ################################################################# + } + if {![llength $indexfiles]} { + continue + } + + set can_skip_sourcing 0 + if {$has_zipfs && [string match $zipfsroot* $dir]} { + #static auto_path dirs + #can avoid scan if added via this path in any epoch + if {[dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { + if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { + #$name wasn't provided by this path before - in static zipfs it shouldn't be necessary to look here again. + #puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath" + set can_skip_sourcing 1 + } else { + #if this name is in added then we must have done a package forget or it wouldn't come back to package unknown ? + #remove it and let it be readded if it's still provided by this path? + #probably doesn't make sense for static path? + #dict unset epoch pkg epochs $pkg_epoch added $currentsearchpath $name + } + } + } else { + #dynamic auto_path dirs - libs could have been added/removed + #scan unless cached negative for this epoch + if {[dict exists $epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name]} { + #puts stderr "zipfs_tclPkgUnknown $tid CAN SKIP $name currentsearchpath:$currentsearchpath (unfound already in epoch $pkg_epoch)" + set can_skip_sourcing 1 + } + } + #An edge case exception is that after a package forget, a deliberate call to 'package require non-existant' + #will not trigger rescans for all versions of other packages. + #A rescan of a specific package for all versions can still be triggered with a package require for + #an exact non-existant version. e.g package require md5 0-0 + #(or misordered min max e.g package require md5 1-0 i.e a deliberately unsatisfiable version range) + + set sourced 0 + if {!$can_skip_sourcing} { + #Note - naive comparison of before_pkgs vs after_pkgs isn't quite enough to tell if something was added. It could have added a version. + #this will stop us rescanning everything properly by doing a 'package require nonexistant' + + #use 'info exists' to only call package names once and then append? worth it? + if {![info exists before_pkgs]} { + set before_pkgs [package names] + } + #update the before_dict which persists across while loop + foreach bp $before_pkgs { + dict set before_dict $bp [package versions $bp] + } + catch { + foreach file $indexfiles { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + #puts stderr "----->0 sourcing $file" + incr sourced ;#count as sourced even if source fails; keep before actual source action + #::tcl::Pkg::source $file + tcl_Pkg_source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + } + set dir [lindex $use_path end] + if {![info exists procdDirs($dir)]} { + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file exists", + if {([interp issafe] || [file exists $file])} { + try { + #puts "----->2 sourcing $file" + incr sourced + #::tcl::Pkg::source $file + tcl_Pkg_source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + #dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create] + + #avoid calculating package and version diffs if nothing was actually sourced + if {$sourced > 0} { + if {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath]} { + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath [dict create] + #ensure there is an empty entry for the path if no packages added or changed versions + } + + set after_pkgs [package names] + set just_added [dict create] + if {[llength $after_pkgs] > [llength $before_pkgs]} { + foreach a $after_pkgs { + if {![dict exists $before_dict $a]} { + dict set just_added $a 1 + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $a $pkg_epoch + } + } + #puts stderr ">>>zipfs_tclPkgUnknown added [llength $added_pkgs]" + #puts stderr ">>> [join [lrange $added_pkgs 0 10] \n]..." + } + dict for {bp bpversions} $before_dict { + if {[dict exists $just_added $bp]} { + continue + } + if {[llength $bpversions] != [llength [package versions $bp]]} { + dict set epoch pkg epochs $pkg_epoch added $currentsearchpath $bp $pkg_epoch + } + } + #puts stderr "zipfs_tclPkgUnknown $tid sourced: $sourced (under path: $currentsearchpath)" + if {$name ni $after_pkgs} { + #cache negative result (for this epoch only) + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } elseif {![dict exists $epoch pkg epochs $pkg_epoch added $currentsearchpath $name]} { + dict set epoch pkg epochs $pkg_epoch unfound $currentsearchpath $name 1 + } + + lappend before_pkgs {*}[dict keys $just_added] + } + } + + } else { + #normal processing - not a static filesystem - we can't skip. + set indexfiles [glob -directory $dir -join -nocomplain * pkgIndex.tcl] + catch { + foreach file $indexfiles { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + #puts "----->1 sourcing $file" + ::tcl::Pkg::source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + } + + set dir [lindex $use_path end] + if {![info exists procdDirs($dir)]} { + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file exists", + if {([interp issafe] || [file exists $file])} { + try { + #puts "----->2 sourcing $file" + ::tcl::Pkg::source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + if {[regexp {version conflict for package} $msg]} { + # In case of version conflict, silently ignore + continue + } + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + + } + + + set use_path [lrange $use_path 0 end-1] + + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. + set index 0 + if {[llength $old_path] == [llength $auto_path]} { + foreach dir $auto_path old $old_path { + if {$dir ne $old} { + # This entry in $::auto_path has changed. + break + } + incr index + } + } + + # $index now points to the first element of $auto_path that has + # changed, or the beginning if $auto_path has changed length Scan the + # new elements of $auto_path for directories to add to $use_path. + # Don't add directories we've already seen, or ones already on the + # $use_path. + foreach dir [lrange $auto_path $index end] { + if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { + lappend use_path $dir + } + } + set old_path $auto_path + } + #puts "zipfs_tclPkgUnknown DONE" + } + proc epoch_incr_pkg {args} { + if {[catch { + global auto_path + upvar ::punk::libunknown::epoch epoch + set prev_e [dict get $epoch pkg current] + set current_e [expr {$prev_e + 1}] + dict set epoch pkg current $current_e + dict set epoch pkg epochs $current_e [dict create] + if {[dict exists $epoch pkg epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + set zroot [zipfs root] + dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] { + if {[string match $zroot* $searchpath]} { + set stillvalid 0 + foreach a $auto_path { + if {[string match $a* $searchpath]} { + set stillvalid 1 + break + } + } + if {$stillvalid} { + dict set epoch pkg epochs $current_e indexes $searchpath $indexfiles + } + } + } + } + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e indexes]] + set index_count 0 + dict for {searchpath indexfiles} [dict get $epoch pkg epochs $prev_e indexes] { + #update prev epoch to be basic statistical info only + incr index_count [llength $indexfiles] + } + dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count] + dict unset epoch pkg epochs $prev_e indexes + } else { + dict set epoch pkg epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0] + } + if {[dict exists $epoch pkg epochs $prev_e added]} { + #bring across - each lib will have previous epoch number + dict set epoch pkg epochs $current_e added [dict get $epoch pkg epochs $prev_e added] + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e added]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e added] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch pkg epochs $prev_e added + } else { + dict set epoch pkg epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0] + } + if {[dict exists $epoch pkg epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch pkg epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch pkg epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch pkg epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch pkg epochs $prev_e unfound + } + } errM]} { + puts stderr "epoch_incr_pkg error\n $errM" + } + } + proc epoch_incr_tm {args} { + if {[catch { + upvar ::punk::libunknown::epoch epoch + set prev_e [dict get $epoch tm current] + set current_e [expr {$prev_e + 1}] + dict set epoch tm current $current_e + dict set epoch tm epochs $current_e [dict create] + set tmlist [tcl::tm::list] + if {[dict exists $epoch tm epochs $prev_e indexes]} { + #bring across the previous indexes records if static filesystem (zipfs) + if {[info commands ::tcl::zipfs::root] ne ""} { + set zroot [zipfs root] + dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] { + if {[string match $zroot* $searchpath]} { + #check all valid for current state of tcl::tm::list + set stillvalid 0 + foreach tm_path $tmlist { + if {[string match $tm_path* $searchpath]} { + set stillvalid 1 + break + } + } + if {$stillvalid} { + dict set epoch tm epochs $current_e indexes $searchpath $indexfiles + } + } + } + } + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e indexes]] + set index_count 0 + dict for {searchpath indexfiles} [dict get $epoch tm epochs $prev_e indexes] { + #update prev epoch to be basic statistical info only + incr index_count [llength $indexfiles] + } + dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count $index_searchpath_count index_count $index_count] + dict unset epoch tm epochs $prev_e indexes + } else { + dict set epoch tm epochs $prev_e indexes_history [dict create searchpath_count 0 index_count 0] + } + if {[dict exists $epoch tm epochs $prev_e added]} { + #bring across - each lib will have previous epoch number + dict set epoch tm epochs $current_e added [dict get $epoch tm epochs $prev_e added] + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e added]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e added] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch tm epochs $prev_e added_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch tm epochs $prev_e added + } else { + dict set epoch tm epochs $prev_e added_history [dict create searchpath_count 0 lib_count 0] + } + if {[dict exists $epoch tm epochs $prev_e unfound]} { + set index_searchpath_count [dict size [dict get $epoch tm epochs $prev_e unfound]] + set lib_count 0 + dict for {searchpath libinfo} [dict get $epoch tm epochs $prev_e unfound] { + dict for {lib e} $libinfo { + if {$e == $prev_e} { + incr lib_count + } + } + } + dict set epoch tm epochs $prev_e unfound_history [dict create searchpath_count $index_searchpath_count lib_count $lib_count] + dict unset epoch tm epochs $prev_e unfound + } + + } errM]} { + puts stderr "epoch_incr_tm error\n $errM" + } + } + + proc init {} { + if {[catch {tcl::tm::list} tmlist]} { + set tmlist [list] + } + set apath [list] + if {[info commands tcl::tm::list] ne ""} { + set tmlist [tcl::tm::list] + } + if {[info exists ::auto_path]} { + set apath $::auto_path + } + if {![llength $tmlist] && ![llength $apath]} { + #shouldn't happen - be noisy about it for now + puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path" + } + + if {[namespace origin ::package] eq "::punk::libunknown::package"} { + #This is far from conclusive - there may be other renamers (e.g commandstack) + return + } + if {[info commands ::punk::libunknown::package] ne ""} { + puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]" + return + } + + trace add variable ::auto_path write ::punk::libunknown::epoch_incr_pkg + trace add variable ::tcl::tm::paths write ::punk::libunknown::epoch_incr_tm + #set stackrecord [commandstack::rename_command -renamer punk::libunknown package {args} { + # #::package override installed by punk::libunknown::init + #} + proc package args { + switch -- [lindex $args 0] { + fo - for - forge - forget { + variable has_package_files + #experimental - silently disallow forgetting things that didn't involve sourcing files + #What about static libs that also sourced files? + #packages loaded by c extensions? + #forgetting Tcl or tcl seems to be a bad idea - package require doesn't work afterwards (independent of this pkg) + set forgets_requested [lrange $args 1 end] + set ok_forgets [list] + foreach p $forgets_requested { + #'package files' not avail in early 8.6 + #There can be other custom 'package ifneeded' scripts that don't use source - but still need to be forgotten. + #a basic/trivial case: 'package ifneeded aaa 0.1.1 {package provide aaa 0.1.1}' + #it could also use 'eval' instead of sourcing. + #For this reason - we shouldn't use 'package files' as any sort of indication of forgetability + #if {$p ni {tcl Tcl} && (!$has_package_files || [package provide $p] eq "" || ($has_package_files && [package provide $p] ne "" && [llength [package files $p]] > 0))} { + # lappend ok_forgets $p + #} + #What then? Hardcoded only for now? + if {$p ni {tcl Tcl tcl::oo}} { + #tcl::oo returns a comment only for its package provide script "# Already present, OK?" + # - so we can't use empty 'ifneeded' script as a determinant. + set vpresent [package provide $p] + if {$vpresent ne ""} { + #There could theoretically be other ifneeded scripts registered - but if the one in use is empty + #we'll use that as the criteria to disallow forget - REVIEW + set ifneededscript [package ifneeded $p $vpresent] + if {[string trim $ifneededscript] ne ""} { + lappend ok_forgets $p + } + } else { + #not loaded - but may have registered ifneeded script(s) in the package database + #assume ok to forget + lappend ok_forgets $p + } + } + } + if {[llength $ok_forgets]} { + return [::package:: forget {*}$ok_forgets] + } else { + return + } + } + ep - epo - epoc - epoch { + upvar ::punk::libunknown::epoch epoch + set epoch_args [lrange $args 1 end] + switch -- [llength $epoch_args] { + 0 { + set tm_epoch [dict get $epoch tm current] + set pkg_epoch [dict get $epoch pkg current] + return [dict create tm $tm_epoch pkg $pkg_epoch] + } + 1 { + switch -- [lindex $epoch_args 0] { + tm { + set cur [dict get $epoch tm current] + return [dict create $cur [dict get $epoch tm epochs $cur]] + } + pkg { + set cur [dict get $epoch pkg current] + return [dict create $cur [dict get $epoch pkg epochs $cur]] + } + incr { + epoch_incr_pkg + epoch_incr_tm + } + default { + error "package epoch [lindex $epoch_args 0] unsupported - known options: tm pkg incr" + } + } + } + 2 { + set a2 [list [lindex $epoch_args 0] [lindex $epoch_args 1]] + switch -- $a2 { + {pkg incr} - {incr pkg} { + epoch_incr_pkg + } + {tm incr} - {incr tm} { + epoch_incr_tm + } + default { + set which [lindex $epoch_args 0] + set index [lindex $epoch_args 1] + if {$which in {pkg tm}} { + set epochs [dict keys [dict get $epoch $which epochs]] + if {[catch { + set epochinfo [dict get $epoch $which epochs $index] + } errM]} { + error "package epoch $which unable to use index $index" + } + return $epochinfo + } else { + error "package epoch {*}$a2 unsupported - expected 'pkg incr' or 'tm incr' or 'pkg ' or 'tm '" + } + } + } + } + default { + set which [lindex $epoch_args 0] + set index [lindex $epoch_args 1] + set keys [lrange $epoch_args 2 end] + if {$which in {pkg tm}} { + set epochs [dict keys [dict get $epoch $which epochs]] + if {[catch { + set epochinfo [dict get $epoch $which epochs $index] + } errM]} { + error "package epoch $which unable to use index $index" + } + if {![dict exists $epochinfo {*}$keys]} { + set topkeys [dict keys $epochinfo] + error "package epoch $which $index $keys not found. Toplevel keys: $topkeys" + } + return [dict get $epochinfo {*}$keys] + } else { + error "package epoch unimplemented" + } + } + } + } + default { + return [::package:: {*}$args] + } + } + } + rename ::package ::package:: + #all lowercase procs already exported from ::punk::libunknown + namespace eval :: [list ::namespace import ::punk::libunknown::package] + + #if {[info commands ::tcl::zipfs::root] ne ""} { + # set has_zipfs_tm 0 + # foreach t $tmlist { + # if {[string match [::tcl::zipfs::root]* $t]} { + # set has_zipfs_tm 1 + # break ;#zipfs_tm_UnknownHandler can handle either - a single zipfs path is enough + # } + # } + # set has_zipfs_auto 0 + # foreach a $apath { + # if {[string match [::tcl::zipfs::root]* $a]} { + # set has_zipfs_auto 1 + # break + # } + # } + # if {$has_zipfs_tm || $has_zipfs_auto} { + # if {$has_zipfs_tm && $has_zipfs_auto} { + # package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + # } elseif {$has_zipfs_tm} { + # package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::tclPkgUnknown} + # } else { + # #must only have auto + # #puts "tmlist : $tmlist" + # #puts "autopath: $apath" + # package unknown {::tcl::tm::UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + # } + # } + # #review - tm and auto_path entries for safebase interps are obscured. For now we will ignore and defaults will apply. + # #to load in safebase anyway - module would probably have to be passed to interp as source to eval? + #} + + if {![interp issafe]} { + package unknown {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} + } + + } + + proc default {} { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::libunknown ---}] +} +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::libunknown +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::libunknown [tcl::namespace::eval punk::libunknown { + variable pkg punk::libunknown + variable version + set version 0.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm index fa9e8d7c..7377929a 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc { cd $original_wd } proc validate {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::mix::commandset::doc::validate - -- -type none -optional 1 -help "end of options marker --" + -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 - } $args] + }] set opt_individual [tcl::dict::get $argd opts -individual] set patterns [tcl::dict::get $argd values patterns] - + #todo - run and validate punk::docgen output set projectdir [punk::repo::find_project] if {$projectdir eq ""} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm index 05e94a25..47e37909 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm @@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout { return [join $layouts \n] } + punk::args::define { + @id -id ::punk::mix::commandset::layout::collection::_default + @cmd -name ::punk::mix::commandset::layout::collection::_default + -startdir -type string + -not -type string -multiple 1 + globsearches -default * -multiple 1 + } proc _default {args} { - punk::args::get_dict [subst { - @id -id ::punk::mix::commandset::layout::collection::_default - @cmd -name ::punk::mix::commandset::layout::collection::_default - -startdir -type string - -not -type string -multiple 1 - globsearches -default * -multiple 1 - }] $args + punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default + set tdict_low_to_high [as_dict {*}$args] #convert to screen order - with higher priority at the top diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 98f171c7..8ef36e27 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap { namespace eval lib { #*** !doctools #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] - #[para] Library API functions for punk::mix::commandset::scriptwrap + #[para] Library API functions for punk::mix::commandset::scriptwrap #[list_begin definitions] - + punk::args::define { + @id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders + #*** !doctools + #[call [fun get_wrapper_folders] [arg args] ] + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo + #[para] Arguments: + # [list_begin arguments] + # [arg_def string args] name-value pairs -scriptpath + # [list_end] + @cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\ + "Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo" + @opts -anyopts 0 + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + @values -minvalues 0 -maxvalues 0 + } proc get_wrapper_folders {args} { - set argd [punk::args::get_dict { - #*** !doctools - #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo - #[para] Arguments: - # [list_begin arguments] - # [arg_def string args] name-value pairs -scriptpath - # [list_end] - @id -id ::punk::mix::commandset::scriptwrap - @cmd -name punk::mix::commandset::get_wrapper_folders - - @opts -anyopts 0 - -scriptpath -default "" -type directory\ - -help "" - #todo -help folder within a punk.templates provided area??? - - @values -minvalues 0 -maxvalues 0 - } $args] + set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders] # -- --- --- --- --- --- --- --- --- set opt_scriptpath [dict get $argd opts -scriptpath] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index bce44dee..f018486d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs { # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied + punk::args::define { + @id -id ::punk::nav::fs::dirfiles_dict + @cmd -name punk::nav::fs::dirfiles_dict + @opts -any 0 + -searchbase -default "" + -tailglob -default "\uFFFF" + #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) + -with_sizes -default "\uFFFF" -type string + -with_times -default "\uFFFF" -type string + @values -min 0 -max -1 -type string + } proc dirfiles_dict {args} { - set argspecs { - @id -id ::punk::nav::fs::dirfiles_dict - @opts -any 0 - -searchbase -default "" - -tailglob -default "\uFFFF" - #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string - -with_times -default "\uFFFF" -type string - @values -min 0 -max -1 -type string - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict] lassign [dict values $argd] leaders opts vals set searchspecs [dict values $vals] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index b89bc021..b8ad757f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -21,7 +21,7 @@ package require punk::lib package require punk::args tcl::namespace::eval ::punk::ns::evaluator { - #eval-_NS_xxx_NS_etc procs + #eval-_NS_xxx_NS_etc procs } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -33,7 +33,7 @@ tcl::namespace::eval punk::ns { } variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns - namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp + namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype resolve_command synopsis namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc catch { @@ -43,7 +43,7 @@ tcl::namespace::eval punk::ns { #debug level punk.ns.compile 3 } - #leading colon makes it hard (impossible?) to call directly if not within the namespace + #leading colon makes it hard (impossible?) to call directly if not within the namespace proc ns/ {v {ns_or_glob ""} args} { variable ns_current ;#change active ns of repl by setting ns_current @@ -67,7 +67,7 @@ tcl::namespace::eval punk::ns { if {$ns_or_glob eq ""} { set is_absolute 1 set ns_queried $ns_current - set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] set has_globchars [regexp {[*?]} $ns_or_glob] @@ -78,10 +78,10 @@ tcl::namespace::eval punk::ns { } set ns_current $ns_or_glob set ns_queried $ns_current - tailcall ns/ $v "" + tailcall ns/ $v "" } else { set ns_queried $ns_or_glob - set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] } } else { if {!$has_globchars} { @@ -91,10 +91,10 @@ tcl::namespace::eval punk::ns { } set ns_current $nsnext set ns_queried $nsnext - set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] } else { set ns_queried [nsjoin $ns_current $ns_or_glob] - set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] } } } @@ -103,7 +103,7 @@ tcl::namespace::eval punk::ns { if {$ns_current in [info commands $ns_current] } { if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { if {[llength $ensemble_info] > 0} { - #this namespace happens to match ensemble command. + #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" } @@ -158,7 +158,7 @@ tcl::namespace::eval punk::ns { } else { set out [get_nslist -match [nsjoin $nsq *] -types [list all]] } - #set out [nslist [nsjoin $nsq *]] + #set out [nslist [nsjoin $nsq *]] set ns_current $nsq append out "\n$ns_current" return $out @@ -252,8 +252,15 @@ tcl::namespace::eval punk::ns { } else { set nsfq $ns } - set ns_script [nseval_ifexists_getscript $nsfq] - uplevel 1 [list {*}$ns_script $script] + if {[lsearch [nsparts $nsfq] :*] >=0} { + #weird_ns + set ns_script [nseval_ifexists_getscript $nsfq] + return [uplevel 1 [list {*}$ns_script $script]] + } else { + if {[namespace exists $nsfq]} { + return [namespace eval $nsfq $script] + } + } } proc nseval_ifexists_getscript {location} { set parts [nsparts $location] @@ -323,7 +330,7 @@ tcl::namespace::eval punk::ns { } #Note nsjoin,nsjoinall,nsprefix,nstail are string functions that don't care about namespaces in existence. - #Some functions in punk::ns are + #Some functions in punk::ns are proc nsjoin {prefix name} { if {[string match ::* $name]} { @@ -422,19 +429,19 @@ tcl::namespace::eval punk::ns { #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y - #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them + #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) - #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string + #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' - #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah - # is this :: punk :etc :blah or :: punk :etc: blah - #clearly leading/trailing colons in namespaces and commands are just a bad idea. + #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah + # is this :: punk :etc :blah or :: punk :etc: blah + #clearly leading/trailing colons in namespaces and commands are just a bad idea. #nsparts will prefer leading colon (ie greedy on ::) #This is important to support leading colon commands such as :/ # ie ::punk:::jjj:::etc -> :: punk :jjj :etc proc nsparts {nspath} { set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] if {[lindex $parts end] eq ""} { @@ -526,7 +533,7 @@ tcl::namespace::eval punk::ns { proc nstree {{location ""}} { if {![string match ::* $location]} { set nscaller [uplevel 1 {::namespace current}] - set location [nsjoin $nscaller $location] + set location [nsjoin $nscaller $location] } list_as_lines [nstree_list $location] } @@ -548,18 +555,18 @@ tcl::namespace::eval punk::ns { set subnslist [dict get $opts -subnslist] set allbelow [dict get $opts -allbelow] ;#whether to return matches longer than the matched glob-path # -- ---- --- --- --- --- - + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $location]] set has_globchars [regexp {[*?]} $ns_absolute] ;#don't use regexes on plain namespaces with no glob chars if {!$has_globchars && !$allbelow && ![llength $subnslist]} { - #short circuit trivial case + #short circuit trivial case return [list $location] } - - set base "" + + set base "" set tailparts [list] - if {$CALLDEPTH == 0} { + if {$CALLDEPTH == 0} { set parts [nsparts $ns_absolute] lset parts 0 :: set idx 0 @@ -577,12 +584,12 @@ tcl::namespace::eval punk::ns { set base $ns_absolute } } else { - set base $location + set base $location set tailparts $subnslist } if {![tcl::namespace::exists $base]} { return [list] - } + } #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] @@ -592,19 +599,19 @@ tcl::namespace::eval punk::ns { #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" - #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx + #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx if {[llength $tailparts]} { set nextglob [lindex $tailparts 0] if {$nextglob eq "**"} { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } elseif {[regexp {[*]{2}$} $nextglob]} { set nslist [list] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] foreach ch $nsmatches { lappend nslist $ch - #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] - lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] - } + #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] + } } else { #lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) set nslist [list] @@ -612,7 +619,7 @@ tcl::namespace::eval punk::ns { if {[llength $tailparts] >1 || $allbelow} { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { #if only one tailpart remaining and not $allbelow - then we already have what we need @@ -626,13 +633,13 @@ tcl::namespace::eval punk::ns { set nslist [list] foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] } } else { set nslist $allchildren } #set nsmatches $allchildren - #set nslist [nstree_list $base -subnslist {} -allbelow 0] + #set nslist [nstree_list $base -subnslist {} -allbelow 0] } set nslist [lsort -unique $nslist] @@ -652,10 +659,10 @@ tcl::namespace::eval punk::ns { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } } @@ -670,14 +677,14 @@ tcl::namespace::eval punk::ns { if {$base ni $nslist} { #puts stderr "> adding $base to $nslist" set nslist [list $base {*}$nslist] - } + } if {$has_globchars} { if {$allbelow} { foreach ns $nslist { if {[globmatchns ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { set nslist_filtered [struct::list::Lfilter $nslist [list globmatchns ${ns_absolute}]] } @@ -687,7 +694,7 @@ tcl::namespace::eval punk::ns { if {[string equal ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { #set nslist_filtered [struct::list::Lfilter $nslist [list string match ${ns_absolute}]] set nslist_filtered [list $ns_absolute] @@ -705,9 +712,54 @@ tcl::namespace::eval punk::ns { if {$ansicodes eq ""} { return $usageinfo_char } elseif {$ansicodes eq "\UFFEF"} { - return " [a+ brightyellow]$usageinfo_char[a]" + return "[a+ brightyellow]$usageinfo_char[a]" + } else { + return "[a+ {*}$ansicodes]$usageinfo_char[a]" + } + } + + punk::args::define { + @id -id ::punk::ns::Cmark + @cmd -name punk::ns::Cmark + @leaders + type -choices {oo ooc ooo punkargs ensemble native} -choicelabels { + oo " symbol \u25c6" + ooc " symbol \u25c7" + ooo " symbol \u25c8" + punkargs " symbol \U1f6c8" + ensemble " symbol \u24ba" + native " symbol \u24c3" + unknown " symbol \u2370" + } + @opts + @values -min 0 -max -1 + ansiname -type string -optional 1 -multiple 1 -help\ + "ansi names as accepted by punk::ansi::a+ + e.g + red bold + (Not raw ansi codes)" + } + proc Cmark {args} { + if {[llength $args] == 0} { + punk::args::parse {} withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + set type [lindex $args 0] + set type [tcl::prefix::match -error "" {oo ooc ooo punkargs ensemble native unknown} $type] + set ansinames [lrange $args 1 end] + switch -- $type { + oo - ooc - ooo - punkargs - ensemble - native - unknown {} + default { + #punk::args::usage ::punk::ns::Cmark + punk::args::parse $args withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + } + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + if {[llength $ansinames]} { + return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]" } else { - return " [a+ {*}$ansicodes]$usageinfo_char[a]" + return [dict get $marks $type] } } @@ -720,7 +772,7 @@ tcl::namespace::eval punk::ns { -nsdict ""\ ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- set fq_glob [dict get $opts -match] set requested_types [dict get $opts -types] set opt_nsdict [dict get $opts -nsdict] @@ -749,7 +801,7 @@ tcl::namespace::eval punk::ns { } foreach t $types { switch -- $t { - oo - all - + oo - all - children - commands - exported - imported - aliases - procs - ensembles - ooclasses - ooobjects - ooprivateobjects - ooprivateclasses - native - coroutines - interps - zlibstreams {} default { error "Unrecognised namespace member type: $t known types: $known_types oo all" @@ -783,19 +835,19 @@ tcl::namespace::eval punk::ns { set usageinfo [list] if {$opt_nsdict eq ""} { - set nsmatches [get_ns_dicts $fq_glob -allbelow 0] + set nsmatches [get_ns_dicts $fq_glob -allbelow 0] set itemcount 0 set matches_with_results [list] foreach nsinfo $nsmatches { - set itemcount [dict get $nsinfo itemcount] + set itemcount [dict get $nsinfo itemcount] if {$itemcount > 0} { lappend matches_with_results $nsinfo - } + } } if {[llength $matches_with_results] == 1} { set contents [lindex $matches_with_results 0] } elseif {[llength $matches_with_results] > 1} { - puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" + puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" set contents [lindex $matches_with_results 0] } else { return "- no results -" @@ -806,7 +858,7 @@ tcl::namespace::eval punk::ns { return "- no results -" } } - set ns [dict get $contents location] + set ns [dict get $contents location] package require overtype if {"children" in $types} { @@ -871,19 +923,19 @@ tcl::namespace::eval punk::ns { } #elements are commands and possibly renamed aliases which may or may not have been renamed into the current namespace - #a command could be an empty string or something else weird. + #a command could be an empty string or something else weird. #Primarily just to handle empty string command - we will wrap each command as a 2-part element here #(our foreach loop needs to ignore missing commands - but not empty string) set elements [lmap v $commands {list c $v}] set seencmds [list] - set masked [list] ;# + set masked [list] ;# #jmn #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { - #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo + #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo #we can detect masking by proc/ensemble/oo - but not by a binary extension loaded after the rename: REVIEW if {$a in $cmdsets} { #we have an alias that is also a known other command-type @@ -896,15 +948,15 @@ tcl::namespace::eval punk::ns { } } set elements [lsort -index 1 $elements] - - + + set numelements [llength $elements] if {$numelements} { set split1 [expr {int(ceil($numelements/4.0))}] set elements1 [lrange $elements 0 $split1-1] set remaining3 [lrange $elements $split1 end] - set numremaining3 [llength $remaining3] + set numremaining3 [llength $remaining3] set split2 [expr {int(ceil($numremaining3/3.0))}] set elements2 [lrange $remaining3 0 $split2-1] set remaining2 [lrange $remaining3 $split2 end] @@ -1019,12 +1071,12 @@ tcl::namespace::eval punk::ns { } } if {$cmd in $usageinfo} { - set u [Usageinfo_mark brightgreen] + set u " [Cmark punkargs brightgreen]" } else { set u "" } set cmd$i "${prefix} $c$cmd_display$u" - #set c$i $c + #set c$i $c set c$i "" lappend seencmds $cmd } @@ -1033,7 +1085,7 @@ tcl::namespace::eval punk::ns { #lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] lappend displaylist $a1[overtype::left $col1 $ch1][a]$a1[overtype::left $col2 $ch2][a]$c1[overtype::left $col3 $cmd1][a]$c2[overtype::left $col4 $cmd2][a]$c3[overtype::left $col5 $cmd3][a]$c4$cmd4[a] } - + return [list_as_lines $displaylist] } proc nspath_here_absolute {{nspath "\uFFFF"}} { @@ -1060,12 +1112,13 @@ tcl::namespace::eval punk::ns { return [nsjoin $base $nspath] } + variable has_textblock set has_textblock [expr {![catch {package require textblock}]}] if {$has_textblock} { interp alias "" ::punk::ns::Block_width "" textblock::width - } else { - #maint - equiv of textblock::width + } else { + #maint - equiv of textblock::width proc Block_width {textblock} { if {$textblock eq ""} { return 0 } if {[tcl::string::last \t $textblock] >=0} { @@ -1085,38 +1138,55 @@ tcl::namespace::eval punk::ns { return [punk::char::ansifreestring_width $textblock] } } - proc nslist {{glob "*"} args} { - set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] - if {[dict exists $args -match]} { - #review - presumably this is due to get_nslist taking -match? - error "nslist requires positional argument 'glob' instead of -match option" - } - set defaults [dict create\ - -match $ns_absolute\ - -nspathcommands 0\ - ] - set opts [dict merge $defaults $args] + punk::args::define { + @id -id ::punk::ns::nslist + @cmd -name punk::ns::nslist -help\ + "Return a textual representation of + the child namespaces and commands within + the namespace(s) matched by glob." + @opts + -nspathcommands -type boolean -default 0 + -types + @values -min 0 -max -1 + glob -multiple 1 -optional 1 -default "*" + } + proc nslist {args} { + set argd [punk::args::parse $args withid ::punk::ns::nslist] + lassign [dict values $argd] leaders opts values received solos multis + + #if {[dict exists $args -match]} { + # #review - presumably this is due to get_nslist taking -match? + # error "nslist requires positional argument 'glob' instead of -match option" + #} + #set defaults [dict create\ + # -match $ns_absolute\ + # -nspathcommands 0\ + #] + #set opts [dict merge $defaults $args] # -- --- --- set opt_nspathcommands [dict get $opts -nspathcommands] # -- --- --- - - - set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + set globlist [dict get $values glob] set with_results [list] - foreach nsdict $ns_matches { - if {[dict get $nsdict itemcount]>0} { - lappend with_results $nsdict + foreach glob $globlist { + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] + set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + foreach nsdict $ns_matches { + if {[dict get $nsdict itemcount]>0} { + lappend with_results $nsdict + } } } - #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' + #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' set count_with_results [llength $with_results] set output "" + variable has_textblock foreach nsdict $with_results { - dict set opts -nsdict $nsdict - set block [get_nslist {*}$opts] + set loc [dict get $nsdict location] + set block [get_nslist -nsdict $nsdict -match ${loc}::* {*}$opts] #if {[string first \n $block] < 0} { # #single line # set width [Block_width [list $block]] @@ -1125,7 +1195,7 @@ tcl::namespace::eval punk::ns { #} set width [Block_width $block] - #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location + #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location if {$count_with_results > 1 || [regexp {[*?]} [nsprefix $ns_absolute]]} { append output \n [dict get $nsdict location] } @@ -1139,17 +1209,24 @@ tcl::namespace::eval punk::ns { } else { append path_text \n " also resolving cmds in namespace paths:" set nspathdict [dict get $nsdict namespacepath] - dict for {k v} $nspathdict { - set cmds [dict get $v commands] - append path_text \n " path: $k" - append path_text \n " cmds: $cmds" + if {!$has_textblock} { + dict for {k v} $nspathdict { + set cmds [dict get $v commands] + append path_text \n " path: $k" + append path_text \n " cmds: $cmds" + } + } else { + dict for {k v} $nspathdict { + set t [textblock::list_as_table -title $k -columns 6 [lsort [dict get $v commands]]] + append path_text \n $t + } } } append output $path_text set path_text_width [Block_width $path_text] - append output \n [string repeat - [expr {max($width,$path_text_width)}]] + append output \n [string repeat - [expr {max($width,$path_text_width)}]] } elseif {$count_with_results > 1 && $width > 0 } { - append output \n [string repeat - $width] + append output \n [string repeat - $width] } } return $output @@ -1160,7 +1237,7 @@ tcl::namespace::eval punk::ns { return [get_ns_dicts $ns_absolute {*}$args] } - #info cmdtype available in 8.7+ + #info cmdtype available in 8.7+ #safe interps also seem to have it disabled for some reason #we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc #IMPORTANT: don't detect easy types such as proc/import here - caller needs the 'na' to do the proper fallback @@ -1227,7 +1304,7 @@ tcl::namespace::eval punk::ns { } #we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller #also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! - return na + return na } #non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob #returns a list of dicts even if only one ns matched @@ -1260,17 +1337,18 @@ tcl::namespace::eval punk::ns { set glob [nstail $fq_glob] set matched_namespaces [nstree_list $nsglob -allbelow $allbelow] - set report_namespaces [list] + set report_namespaces [list] #special case trailing ** in last segment if {[regexp {[*]{2}$} $glob]} { - lappend report_namespaces {*}$matched_namespaces + lappend report_namespaces {*}$matched_namespaces foreach ns $matched_namespaces { lappend report_namespaces {*}[nstree_list [nsjoin $ns $glob]] } } else { - set report_namespaces $matched_namespaces + set report_namespaces $matched_namespaces } - punk::args::update_definitions $report_namespaces + #puts stderr "---->get_ns_dicts '$fq_glob $args' update_definitions $report_namespaces" + punk::args::update_definitions $report_namespaces set nsdict_list [list] foreach ch $report_namespaces { @@ -1280,27 +1358,27 @@ tcl::namespace::eval punk::ns { } else { set allchildren [nschildren $ch] ; #sorted, only returns 1 level deeper } - + #nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string. # By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {} #set commands [.= nscommands -raw [nsjoin $ch $glob] |> punk::lib::linelist -block {}] set commands [punk::lib::linelist -block {} [nscommands -raw [nsjoin $ch $glob]]] - #by convention - returning just \n represents a single result of the empty string whereas no results + #by convention - returning just \n represents a single result of the empty string whereas no results #after passing through linelist this becomes {} {} which appears as a list of two empty strings. - #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines + #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines #unless we always return a newline at the tail if there is a result #For this reason nscommands returns a trailing newline - so the last entry should always be empty string - and is a bogus entry - #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. + #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. if {[lindex $commands end] eq ""} { set commands [lrange $commands 0 end-1] } else { puts stderr "get_ns_dicts WARNING nscommands didn't return a trailing newline - unexpected" } - - + + #JMN - set location $ch + set location $ch set locationparts [nsparts $location] set weird_ns 0 if {[lsearch $locationparts :*] >= 0} { @@ -1309,7 +1387,7 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set exportpatterns [nseval_ifexists $location {::namespace export}] set nspathlist [nseval_ifexists $location {::namespace path}] - } else { + } else { set exportpatterns [tcl::namespace::eval $location {::namespace export}] set nspathlist [tcl::namespace::eval $location {::namespace path}] } @@ -1335,7 +1413,7 @@ tcl::namespace::eval punk::ns { #! info commands can't glob with a weird ns prefix #! info commands with no arguments returns all commands (from global and any other ns in namespace path) #lappend matched {*}[nseval_ifexists $location [list ::info commands [nsjoin ${location} $p]]] - lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { + lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { set allcommands [info commands] set matches [list] foreach c $allcommands { @@ -1360,9 +1438,9 @@ tcl::namespace::eval punk::ns { set allexported [lsort -unique $allexported] #NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace) if {$weird_ns} { - set allprocs [nseval_ifexists $location {::info procs}] + set allprocs [nseval_ifexists $location {::info procs}] } else { - set allprocs [tcl::namespace::eval $location {::info procs}] + set allprocs [tcl::namespace::eval $location {::info procs}] } #set allprocs [nseval $location {::info procs}] set childtails [lmap v $allchildren {nstail $v}] @@ -1382,24 +1460,24 @@ tcl::namespace::eval punk::ns { #use aliases glob - because aliases can be present with or without leading :: #NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases if {$weird_ns} { - set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } else { - set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } - #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] foreach a $raw_aliases { if {[string match *:: $a]} { #exception for alias such as ::p::2:: so that it doesn't show up as empty string #lappend aliases :: #JMN - 2023 - better to display an empty string somehow - lappend aliases "" + lappend aliases "" } else { lappend aliases [nstail $a] } } - #NOTE for 'info ...' 'namespace origin|(etc)..' + #NOTE for 'info ...' 'namespace origin|(etc)..' # - use the pattern [namespace eval $location [list $cmd]] #This allows examination of cmds with "bad" names such as empty string or prefixed with single colon. #while these should be rare - we want to handle such edge cases when browsing namespaces. @@ -1433,7 +1511,7 @@ tcl::namespace::eval punk::ns { } if {$weird_origin} { if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { @@ -1444,7 +1522,7 @@ tcl::namespace::eval punk::ns { } } else { if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { @@ -1454,7 +1532,7 @@ tcl::namespace::eval punk::ns { } } - } + } default { if {$ctype eq "import"} { if {$weird_ns} { @@ -1462,7 +1540,7 @@ tcl::namespace::eval punk::ns { } else { set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] } - #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source + #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source #ie we don't need to follow a chain of 'imported' results. set origin_location [nsprefix $cmdorigin] set origin_cmd [nstail $cmdorigin] @@ -1491,7 +1569,7 @@ tcl::namespace::eval punk::ns { lappend allensembles $cmd } i-alias - alias { - #review + #review lappend allaliases $cmd } i-object - object { @@ -1520,7 +1598,7 @@ tcl::namespace::eval punk::ns { lappend allzlibstreams $cmd } default { - #there may be other registered types + #there may be other registered types #(extensible with Tcl_RegisterCommandTypeName) lappend allothers $cmd } @@ -1535,7 +1613,7 @@ tcl::namespace::eval punk::ns { #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. set nsorigin [namespace origin ${location}::] } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] + set nsorigin [nseval $location "::namespace origin $cmd"] } else { set nsorigin [namespace origin [nsjoin $location $cmd]] } @@ -1585,12 +1663,12 @@ tcl::namespace::eval punk::ns { set imported $allimported set undetermined $allundetermined } - - #itemcount will overcount if we are including commands as well as procs/exported etc - + + #itemcount will overcount if we are including commands as well as procs/exported etc - set itemcount 0 incr itemcount [llength $childtailmatches] incr itemcount [llength $commands] - + #incr itemcount [llength $procs] #incr itemcount [llength $exported] @@ -1606,6 +1684,7 @@ tcl::namespace::eval punk::ns { set has_punkargs [expr {[info commands ::punk::args::id_exists] ne ""}] set has_tepam [expr {[info exists ::tepam::ProcedureList]}] if {$has_punkargs || $has_tepam} { + set ns_updated [dict create] foreach c $commands { if {$c in $imported} { set fq [namespace origin [nsjoin $location $c]] @@ -1613,7 +1692,7 @@ tcl::namespace::eval punk::ns { #TODO - use which_alias ? set tgt [interp alias "" [nsjoin $location $c]] if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] + set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] } set word1 [lindex $tgt 0] if {$word1 eq "punk::mix::base::_cli"} { @@ -1623,7 +1702,11 @@ tcl::namespace::eval punk::ns { } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) - set fq $word1 + if {[string match ::* $word1]} { + set fq $word1 + } else { + set fq ::$word1 + } } } else { set fq [nsjoin $location $c] @@ -1631,7 +1714,12 @@ tcl::namespace::eval punk::ns { if {$has_punkargs} { #set id [string trimleft $fq :] set id $fq - punk::args::update_definitions [list [namespace qualifiers $id]] + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1675,10 +1763,10 @@ tcl::namespace::eval punk::ns { ] lappend nsdict_list $nsdict } - return $nsdict_list + return $nsdict_list } #Must be no ansi when only single arg used. - #review - ansi codes will be very confusing in some scenarios! + #review - ansi codes will be very confusing in some scenarios! #todo - only output color when requested (how?) or via repltelemetry ? interp alias {} nscommands2 {} .= ,'ok'@0.= { #Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x @@ -1688,13 +1776,13 @@ tcl::namespace::eval punk::ns { ::set commandns [::namespace current] ::set commandlist [::list] #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway - #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed + #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed ::set colors [::list none cyan yellow green] ::set ci 0 ;#colourindex ::set do_raw 0 ::if {[::set posn [::lsearch $searchlist -raw]] >= 0} { ::set searchlist [::lreplace $searchlist $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } ::if {![::llength $searchlist]} { ::lappend searchlist * @@ -1714,7 +1802,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1731,7 +1819,7 @@ tcl::namespace::eval punk::ns { ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } if 0 { @@ -1771,19 +1859,19 @@ tcl::namespace::eval punk::ns { ::list ok [::list result $commandlist] #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. - } |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} = 0} { ::set args [::lreplace $args $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } if {![llength $args]} { lappend args * @@ -1801,7 +1889,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1817,7 +1905,7 @@ tcl::namespace::eval punk::ns { set weird_ns 0 if {[string match *:::* $base]} { set weird_ns 1 - } + } #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created if {$weird_ns} { ::if {![nsexists $base]} { @@ -1838,7 +1926,7 @@ tcl::namespace::eval punk::ns { }} $base $what ]] } else { ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] } @@ -1903,7 +1991,7 @@ tcl::namespace::eval punk::ns { info commands ${input} } } - } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + } errM]} { + puts stderr "$errM" + set origin $querycommand + set resolved $querycommand + } + } else { + #fully qualified command specified but doesn't exist + set origin $querycommand + set resolved $querycommand + } + } else { + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand + } else { + #set thispath [uplevel 1 [list ::nsthis $querycommand]] + set thispath [uplevel 1 [list ::punk::ns::nspath_here_absolute $querycommand]] + set targetns [nsprefix $thispath] + set name [nstail $thispath] + set targetparts [nsparts $targetns] + if {[lsearch $targetparts :*] >=0} { + #weird ns + set valid_ns [nsexists $targetns] + } else { + set valid_ns [namespace exists $targetns] + } + if {$valid_ns} { + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + }]} { + set thiscmd [nsjoin $targetns $name] + #relative querycommand specified - but Tcl didn't find a match in namespace path + #assume global (todo - look for namespace match in auto_index first ?) + set origin ::$name + set resolved ::$name + } + } else { + #namespace as relative to current doesn't seem to exist + #Tcl would also attempt to resolve as global + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::resolve_command $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand + + } + } + } + #ns::cmdtype only detects alias type on 8.7+? + set initial_cmdtype [punk::ns::cmdtype $origin] + switch -- $initial_cmdtype { + na - alias { + #REVIEW - alias entry doesn't necessarily match command! + #consider using which_alias (wiki) + set tgt [interp alias "" $origin] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft $origin :]] + } + #first word of tgt may be namespace relative or absolute + if {$tgt ne ""} { + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set targetword [lindex $tgt end] + } else { + #todo - alias may have prefilled some leading args - so usage report should reflect that??? + #(possible curried arguments) + #review - curried arguments could be for ensembles! + set targetword $word1 + return [namespace eval :: [list punk::ns::resolve_command $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + } + + + set origin $targetword + #retest cmdtype on modified origin + set cmdtype [punk::ns::cmdtype $origin] + } else { + set cmdtype $initial_cmdtype + } + if {$cmdtype eq "na"} { + #tcl 8.6 + if {[info object isa object $origin]} { + set cmdtype "object" + } + } + } + default { + set cmdtype $initial_cmdtype + } + } + + punk::args::update_definitions [list [namespace qualifiers $origin]] + set id $origin + + + #don't shortcircuit if no args id - need to allow (autodef) even for argumentless query e.g resolve_command dict + if {[punk::args::id_exists $id] && ![llength $queryargs]} { + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + #puts "--->resolve_command '$args' update_definitions [list [namespace qualifiers $origin]]" + if {![punk::args::id_exists $origin]} { + if {[namespace ensemble exists $origin]} { + #review + #todo - check -unknown + #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + #presumably -choiceprefix should be zero in that case?? + + set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] + + #review - we can have a combination of commands from -map as well as those exported from -namespace + # if and only if -subcommands is specified + + set subcommand_dict [dict create] + set commands [list] + set nscommands [list] + if {[llength [dict get $ensembleinfo -subcommands]]} { + #set exportspecs [namespace eval $ns {namespace export}] + #foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + #} + #when using -subcommands, even unexported commands are available + set nscommands [info commands ${ns}::*] + foreach sub [dict get $ensembleinfo -subcommands] { + if {[dict exists $map $sub]} { + #-map takes precence over same name exported from -namespace + dict set subcommand_dict $sub [dict get $map $sub] + } elseif {"${ns}::$sub" in $nscommands} { + dict set subcommand_dict $sub ${ns}::$sub + } else { + #subcommand probably supplied via -unknown handler? + dict set subcommand_dict $sub "" + } + } + } else { + if {[dict size $map]} { + set subcommand_dict $map + } else { + set exportspecs [namespace eval $ns {namespace export}] + foreach pat $exportspecs { + lappend nscommands {*}[info commands ${ns}::$pat] + } + foreach fqc $nscommands { + dict set subcommand_dict [namespace tail $fqc] $fqc + } + } + } + + + set subcommands [lsort [dict keys $subcommand_dict]] + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs + } + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + #must be exact match - not a prefix + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set resolve_next [list {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + puts "+++> resolve_next: $resolve_next" + + set sub_resolution [resolve_command {*}$resolve_next] + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + + #set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match] + + puts stderr "+++> $sub_resolution" + puts stderr "+++> $f" + dict set sub_resolution args_full $f + return $sub_resolution + } + } + + set choiceinfodict [dict create] + set choicelabeldict [dict create] + + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + dict set choiceinfodict $sub [list [list resolved $subwhat]] + + if {$targettail in [dict get $nsinfo usageinfo]} { + dict lappend choiceinfodict $sub {doctype punkargs} + #dict set choicelabeldict $sub [punk::ns::synopsis $subwhat] + } + if {$targettail in [dict get $nsinfo ensembles]} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + if {$targettail in [dict get $nsinfo ooobjects]} { + if {$targettail in [dict get $nsinfo ooclasses]} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$targettail in [dict get $nsinfo native]} { + dict lappend choiceinfodict $sub {doctype native} + } + } + + + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + set argdef [punk::lib::tstr -return string { + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + Ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -ensembleparameter 1 -help {leading ensemble parameter - passed to subcommand}" + } + } + append argdef \n $vline + punk::args::define $argdef + set id $autoid + } + } + #testing where id = $origin or id = (autodef)::$origin + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set specid $id + set specargs $queryargs + if {[llength $queryargs]} { + #JJJ + set spec [punk::args::get_spec $id] + #TODO -form + set form_names [dict get $spec form_names] + + #'subcommands' only allowed in single-form commands - review + set fid [lindex $form_names 0] + + set leadernames [dict get $spec FORMS $fid LEADER_NAMES] + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + #'subcommands' are only present in forms that consist solely of leaders - REVIEW + #(does not have to dispatch on 1st leader - e.g consider ensemble -parameters) + if {[llength $form_names] == 1 && ![llength $optnames] && ![llength $valnames]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + + set leadernames_matched [lrange $leadernames 0 [llength $queryargs]-1] + foreach q $queryargs lname $leadernames_matched { + if {$lname eq ""} { + break + } + set arginfo [dict get $spec FORMS $fid ARG_INFO $lname] + + set allchoices [list] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + set choiceinfo [punk::args::system::Dict_getdef $arginfo -choiceinfo {}] + set is_ensembleparam [punk::args::system::Dict_getdef $arginfo -ensembleparameter 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 {*}$clist + } + if {$is_ensembleparam} { + #review + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + if {![llength $allchoices]} { + #review - only leaders with a defined set of choices are eligible for consideration as a subcommand + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + + + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + break + } + if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { + #a unique prefix is not sufficient for this arg + break + } + + lappend nextqueryargs $resolved_q + lpop queryargs_untested 0 + if {$resolved_q ne $q} { + #we have our first difference - recurse with new query args + set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested] + set sub_resolution [punk::ns::resolve_command {*}$resolvelist] + #return $sub_resolution + + set sub_origin [dict get $sub_resolution origin] + set sub_argsremaining [dict get $sub_resolution args_remaining] + set sub_resolved [dict get $sub_resolution resolved] + set sub_cmdtype [dict get $sub_resolution cmdtype] + set sub_args_full [dict get $sub_resolution args_full] + puts stderr "===> $sub_resolution" + + return [dict create origin $sub_origin args_remaining $sub_argsremaining resolved $sub_resolved cmdtype $sub_cmdtype args_full $resolvelist] + + } + #check if subcommands so far have a custom args def + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set spec [punk::args::get_spec $currentid] + set form_names [dict get $spec form_names] + set fid [lindex $form_names 0] + + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] + + if {[llength $form_names] != 1} { + break + } + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + if {[llength $optnames] || [llength $valnames]} { + break + } + } else { + set is_subcommand_resolved 0 + set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] + set mapped_subcmd "" + foreach inf $cinfo { + if {[lindex $inf 0] eq "resolved"} { + set mapped_subcmd [lindex $inf 1] + set resolve_next [list {*}$mapped_subcmd {*}$queryargs_untested] + puts "---> resolve_next: $resolve_next" + set sub_resolution [punk::ns::resolve_command {*}$resolve_next] + + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + #set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs] + + puts stderr "---> $sub_resolution" + puts stderr "---> $f" + dict set sub_resolution args_full $f + return $sub_resolution + + + #puts stderr "---> $sub_resolution" + #return $sub_resolution + } + } + + #We can get no further with custom defs + #It is possible we have a documented lower level subcommand but missing the intermediate + #e.g if ::trace remove command was specified and is documented - it will be found above + #but if ::trace remove is not documented and the query is "::trace remove com" + #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + #that's probably ok. + break + } + } + } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs + } + } + + if {[string match (autodef)* $origin]} { + set origin [string range $origin 9 end] + } + + + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + punk::args::define { + @id -id ::punk::ns::forms + @cmd -name punk::ns::forms -help\ + "Return names for each form of a command" + @opts + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc forms {args} { + set argd [::punk::args::parse $args withid ::punk::ns::forms] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::forms $id + } + punk::args::define { + @id -id ::punk::ns::synopsis + @cmd -name punk::ns::synopsis -help\ + "Return synopsis for each form of a command + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc synopsis {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set opt_return [dict get $argd opts -return] + set cmdmembers [dict get $argd values cmditem] + + + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set resolved_id [dict get $cmdinfo origin] + set unresolved_args [dict get $cmdinfo args_remaining] + set full_args [dict get $cmdinfo args_full] + + #puts "---punk::args::synopsis resolve_command result: $cmdinfo" + #REVIEW + set n [llength $unresolved_args] + set idparts [lrange $full_args 0 end-$n] + + set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + if {$syn eq ""} { + return + } + + #when we use list operations on $syn - it can get extra braces due to ANSI - use join to bring back to a string without extraneous bracing + switch -- $opt_return { + full - summary { + set resultstr "" + foreach synline [split $syn \n] { + #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n + append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + } + set resultstr [string trimright $resultstr \n] + #set resultstr [join [lreplace $syn 0 0 {*}$idparts] " "] + return $resultstr + } + dict { + return $syn + } + } + } + proc synopsis_raw {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::synopsis -form $form $id + } + #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? # - as this is interactive generally introspection should be ok at the top level # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? @@ -1989,15 +2596,15 @@ tcl::namespace::eval punk::ns { It supports the following: 1) Procedures or builtins for which a punk::args definition has been loaded. - 2) tepam procedures (returns string form only) + 2) tepam procedures (returns string form only) 3) ensemble commands - auto-generated unless documented via punk::args (subcommands will show with an indicator if they are explicitly documented or are themselves ensembles) - 4) tcl::oo objects - auto-gnerated unless documented via punk::args + 4) tcl::oo objects - auto-gnerated unless documented via punk::args 5) dereferencing of aliases to find underlying command (will not work with some renamed aliases) - Note that native commands commands not explicitly documented will + Note that native commands commands not explicitly documented will generally produce no useful info. For example sqlite3 dbcmd objects could theoretically be documented - but as 'info cmdtype' just shows 'native' they can't (?) be identified as belonging to sqlite3 without @@ -2009,7 +2616,8 @@ tcl::namespace::eval punk::ns { } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - + -form -default 0 -help\ + "Ordinal index or name of command form" -- -type none -help\ "End of options marker Use this if the command to view begins with a -" @@ -2026,19 +2634,21 @@ tcl::namespace::eval punk::ns { #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { - dict set opts -scheme info + #dict set opts -scheme info + set scheme_received 0 + } else { + set scheme_received 1; #so we know not to override caller's explicit choice } set querycommand [dict get $values commandpath] set queryargs [dict get $values subcommand] #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented if {[string match ::* $querycommand]} { set targetns [nsprefix $querycommand] set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global + #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global #when arginfo given a fully qualified path - we only want an answer for that exact command set nscommands [info commands ${targetns}::*] if {[lsearch -exact $nscommands $querycommand] >= 0} { @@ -2051,14 +2661,14 @@ tcl::namespace::eval punk::ns { set resolved $querycommand } } else { - #fully qualified command specified but doesn't exist + #fully qualified command specified but doesn't exist set origin $querycommand set resolved $querycommand } } else { #relative comandpath if {[string match (autodef)* $querycommand]} { - #pass through - should be found with id lookup + #pass through - should be found with id lookup set origin $querycommand set resolved $querycommand } else { @@ -2091,6 +2701,9 @@ tcl::namespace::eval punk::ns { ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] if {$nscaller ne "::"} { + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] } @@ -2104,9 +2717,32 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { + #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { - return [uplevel 1 [list punk::args::usage {*}$opts $origin]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } } } } @@ -2116,7 +2752,7 @@ tcl::namespace::eval punk::ns { switch -- $initial_cmdtype { na - alias { #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) + #consider using which_alias (wiki) set tgt [interp alias "" $origin] if {$tgt eq ""} { set tgt [interp alias "" [string trimleft $origin :]] @@ -2133,9 +2769,12 @@ tcl::namespace::eval punk::ns { #(possible curried arguments) #review - curried arguments could be for ensembles! set targetword $word1 - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] #puts "ALIAS THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] } @@ -2167,9 +2806,33 @@ tcl::namespace::eval punk::ns { #REVIEW - this doesn't cater for prefix callable subcommands set argcopy $queryargs if {[llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "====>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists [list $id {*}$queryargs]]} { - return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + } } } #while {[llength $argcopy]} { @@ -2182,21 +2845,46 @@ tcl::namespace::eval punk::ns { #didn't find any exact matches #traverse from other direction taking prefixes into account - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists $id]} { #cycle forward through leading values - set spec [punk::args::get_spec $id] + set specid $id + set specargs $queryargs if {[llength $queryargs]} { - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + #jjj + set spec [punk::args::get_spec $id] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs set queryargs_untested $queryargs foreach q $queryargs { - if {[llength [dict get $spec LEADER_NAMES]]} { - set subitems [dict get $spec LEADER_NAMES] + if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + set subitems [dict get $spec FORMS $fid LEADER_NAMES] if {[llength $subitems]} { set next [lindex $subitems 0] - set arginfo [dict get $spec ARG_INFO $next] + set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - set allchoices [list] + set allchoices [list] set choices [punk::args::system::Dict_getdef $arginfo -choices {}] set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] if {[dict exists $choicegroups ""]} { @@ -2214,18 +2902,45 @@ tcl::namespace::eval punk::ns { lappend nextqueryargs $resolved_q lpop queryargs_untested 0 if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - #set numvals [expr {[llength $queryargs]+1}] + #we have our first difference - recurse with new query args + #set numvals [expr {[llength $queryargs]+1}] #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - return [ punk::ns::arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested] + if {!$scheme_received} { + dict unset opts -scheme + } + return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] } #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list $id {*}$nextqueryargs] + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] if {[punk::args::id_exists $currentid]} { set spec [punk::args::get_spec $currentid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] } else { #We can get no further with custom defs #It is possible we have a documented lower level subcommand but missing the intermediate @@ -2242,8 +2957,34 @@ tcl::namespace::eval punk::ns { } } } else { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs } } @@ -2261,10 +3002,10 @@ tcl::namespace::eval punk::ns { #the call: info object methods -all # seems to do the right thing as far as hiding unexported methods, and showing things like destroy # - which don't seem to be otherwise easily introspectable - set public_methods [info object methods $origin -all] + set public_methods [info object methods $origin -all] #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - + if {[llength $queryargs]} { set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { @@ -2277,13 +3018,13 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} new" -help\ "create object with specified command name. Arguments are passed to the constructor." - @values + @values }] set i 0 foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2294,7 +3035,31 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin new"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin new"] + } } create { set constructorinfo [info class constructor $origin] @@ -2304,7 +3069,7 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} create" -help\ "create object with specified command name. Arguments following objectName are passed to the constructor." - @values -min 1 + @values -min 1 objectName -type string -help\ "possibly namespaced name for object instance command" }] @@ -2312,7 +3077,7 @@ tcl::namespace::eval punk::ns { foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2323,29 +3088,77 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin create"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin create"] + } } destroy { #review - generally no doc # but we may want notes about a specific destructor set argdef [punk::lib::tstr -return string { - @id -id "(audodef)${$origin} destroy" + @id -id "(autodef)${$origin} destroy" @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." @values -min 0 -max 0 }] punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + } } default { - #use info object call to resolve callchain + #use info object call to resolve callchain #we assume the first impl is the topmost in the callchain # and its call signature is therefore the one we are interested in - REVIEW # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? set implementations [::info object call $origin $c1] - #result documented as list of 4 element lists - #set callinfo [lindex $implementations 0] + #result documented as list of 4 element lists + #set callinfo [lindex $implementations 0] set oodef "" foreach impl $implementations { lassign $impl generaltype mname location methodtype @@ -2396,7 +3209,7 @@ tcl::namespace::eval punk::ns { switch -- [llength $a] { 1 { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2422,6 +3235,7 @@ tcl::namespace::eval punk::ns { } } set choicelabeldict [dict create] + set choiceinfodict [dict create] foreach cmd $public_methods { switch -- $cmd { new - create - destroy { @@ -2437,13 +3251,16 @@ tcl::namespace::eval punk::ns { if {$location eq "object"} { #set id "[string trimleft $origin :] $cmd" ;# " " set id "$origin $cmd" + dict set choiceinfodict $cmd {{doctype ooo}} } else { #set id "[string trimleft $location :] $cmd" ;# " " set id "$location $cmd" + dict set choiceinfodict $cmd {{doctype ooc}} } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { - dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + dict lappend choiceinfodict $cmd {doctype punkargs} } } break @@ -2451,6 +3268,7 @@ tcl::namespace::eval punk::ns { filter { } unknown { + dict set choiceinfodict $cmd {{doctype unknown}} } } } @@ -2458,11 +3276,11 @@ tcl::namespace::eval punk::ns { } } - set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review + set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" set idauto "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$idauto} + @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @leaders -min 1 @@ -2492,6 +3310,7 @@ tcl::namespace::eval punk::ns { #presumably -choiceprefix should be zero in that case?? set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] set prefixes [dict get $ensembleinfo -prefixes] set map [dict get $ensembleinfo -map] set ns [dict get $ensembleinfo -namespace] @@ -2537,54 +3356,142 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] if {[llength $queryargs]} { - set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs } - } - - set namespaces [list] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set ns [::namespace which $subwhat] - if {$ns ni $namespaces} { - lappend namespaces $ns + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + if {!$scheme_received} { + dict unset opts -scheme + } + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #use tailcall so %caller% is reported properly in error msg + tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + } } } + set have_usageinfo [list] set is_ensemble [list] set is_object [list] - foreach ns $namespaces { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin [nsprefix $ns] *]] 0] - lappend have_usageinfo {*}[dict get $nsinfo usageinfo] - lappend is_ensemble {*}[dict get $nsinfo ensembles] - lappend is_object {*}[dict get $nsinfo ooobjects] + set is_class [list] + set is_native [list] + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + if {$targettail in [dict get $nsinfo usageinfo]} { + lappend have_usageinfo $sub + } + if {$targettail in [dict get $nsinfo ensembles]} { + lappend is_ensemble $sub + } + if {$targettail in [dict get $nsinfo ooobjects]} { + lappend is_object $sub + } + if {$targettail in [dict get $nsinfo ooclasses]} { + lappend is_class $sub + } + if {$targettail in [dict get $nsinfo native]} { + lappend is_native $sub + } } + #todo - synopsis? set choicelabeldict [dict create] + + set choiceinfodict [dict create] foreach sub $subcommands { + + if {$sub in $is_ensemble} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + + if {$sub in $is_object} { + if {$sub in $is_class} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$sub in $is_native} { + dict lappend choiceinfodict $sub {doctype native} + } + if {$sub in $have_usageinfo} { - dict set choicelabeldict $sub " [Usageinfo_mark brightgreen]" - } elseif {$sub in $is_ensemble} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" - } elseif {$sub in $is_object} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" + #dict set choiceinfodict $sub [list {doctype punkargs}] + dict lappend choiceinfodict $sub {doctype punkargs} } } - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] set autoid "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} + @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @leaders -min 1 }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } + } append argdef \n $vline punk::args::define $argdef - return [punk::args::usage {*}$opts $autoid] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { + # parsing error e.g Bad number of leading values + #override -scheme in opts with -scheme error + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] + } + #return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2650,14 +3557,41 @@ tcl::namespace::eval punk::ns { } if {[llength $queryargs]} { - #todo - something better - set msg "Undocumented or nonexistant subcommand $origin $queryargs" + #todo - something better ? + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + + if {[punk::args::id_exists $origin]} { + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } + } + set msg "Undocumented or nonexistant command $origin $queryargs" append msg \n "$origin Type: $cmdtype" } else { if {$cmdtype eq "proc"} { set msg "Undocumented proc $origin" append msg \n "No argument processor detected" - append msg \n "function signature: $resolved $argl" + append msg \n "function signature: $resolved $argl" } else { set msg "Undocumented command $origin. Type: $cmdtype" } @@ -2667,15 +3601,15 @@ tcl::namespace::eval punk::ns { #todo - package up as navns proc corp {path} { - #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp + #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) if {[info exists punk::console::tabwidth]} { set tw $::punk::console::tabwidth } else { - set tw 8 + set tw 8 } - set indent [string repeat " " $tw] ;#match - #set indent [string repeat " " $tw] ;#A more sensible default for code - review + set indent [string repeat " " $tw] ;#match + #set indent [string repeat " " $tw] ;#A more sensible default for code - review if {[info exists ::auto_index($path)]} { set body "\n${indent}#corp# auto_index $::auto_index($path)" @@ -2695,7 +3629,7 @@ tcl::namespace::eval punk::ns { } #puts stderr "corp upns:$upns" - #set name [string trim $name :] + #set name [string trim $name :] #set origin [namespace origin ${upns}::$name] set origin [nseval $targetns [list ::namespace origin $name]] set resolved [nseval $targetns [list ::namespace which $name]] @@ -2703,7 +3637,7 @@ tcl::namespace::eval punk::ns { #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! if {$origin ni [info procs $origin]} { - #It seems an interp alias of "::x"" behaves the same as "x" + #It seems an interp alias of "::x"" behaves the same as "x" #But we can't create both at the same time - and they have to be queried by the exact name. #So we query for alias with and without leading :: set alias_qualified [interp alias {} [string trim $origin :]] @@ -2727,7 +3661,7 @@ tcl::namespace::eval punk::ns { #depending on number of aliases in the chain return [list alias {*}$alias] } - } + } if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { append body \n "${indent}#corp# namespace origin $origin" } @@ -2737,7 +3671,7 @@ tcl::namespace::eval punk::ns { } if {![catch {package require textutil::tabify} errpkg]} { set bodytext [info body $origin] - #punk::lib::indent preserves trailing empty lines - unlike textutil version + #punk::lib::indent preserves trailing empty lines - unlike textutil version set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] append body [punk::lib::indent $bodytext $indent] } else { @@ -2880,17 +3814,17 @@ tcl::namespace::eval punk::ns { set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] if {!$ns_populated} { - #we will catch-run an auto_index entry if any - #auto_index entry may or may not be prefixed with :: + #we will catch-run an auto_index entry if any + #auto_index entry may or may not be prefixed with :: set keys [list] #first look for exact pkg_unqualified and ::pkg_unqualified #leave these at beginning of keys list if {[array exists ::auto_index($pkg_unqualified)]} { - lappend keys $pkg_unqualified - } + lappend keys $pkg_unqualified + } if {[array exists ::auto_index(::$pkg_unqualified)]} { - lappend keys ::$pkg_unqualified - } + lappend keys ::$pkg_unqualified + } #as auto_index is an array - we could get keys in arbitrary order set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]] lappend keys {*}$matches @@ -2902,8 +3836,8 @@ tcl::namespace::eval punk::ns { set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] while {!$ns_populated && $i < [llength $keys]} { #todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base - #e.g if we are loading ::x::y - #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc + #e.g if we are loading ::x::y + #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc set k [lindex $keys $i] set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { @@ -2916,7 +3850,7 @@ tcl::namespace::eval punk::ns { } incr i } - + } } } @@ -2924,7 +3858,7 @@ tcl::namespace::eval punk::ns { if {[llength $cmdargs]} { set binding {} #if {[info level] == 1} { - # #up 1 is global + # #up 1 is global # set get_vars [list info vars] #} else { # set get_vars [list info locals] @@ -2955,7 +3889,7 @@ tcl::namespace::eval punk::ns { } else { #A variable can show in the results for 'info vars' (or nsvars) but still not exist. e.g a 'variable x' declaration in the namespace where the variable has never been set } - } + } return [dict create vars $capturevars arrs $capturearrs] } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) } ] @@ -2963,7 +3897,7 @@ tcl::namespace::eval punk::ns { set arglist [lassign $cmdargs scriptblock] if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} { - #one liner without use of $args + #one liner without use of $args append scriptblock { {*}$args} #tailcall apply [list args [string cat $scriptblock { {*}$args}] $ns] {*}$arglist } @@ -3043,7 +3977,7 @@ tcl::namespace::eval punk::ns { error "nsimport_noclobber error namespace $source_ns not found" } - set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] + set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] set a_commands [info commands $pat] #puts "-->commands:'$a_commands'" set a_tails [lmap v $a_commands {tcl::namespace::tail $v}] @@ -3053,11 +3987,11 @@ tcl::namespace::eval punk::ns { foreach m $matches { #we will be using namespace import one by one on commands. #we must protect glob chars that may exist in the actual command names. - #e.g nsimport_noclobber ::punk::ansi::a? + #e.g nsimport_noclobber ::punk::ansi::a? # will import a+ and a? #but nsimport_noclobber {::punk::ansi::a\?} # must import only a? - set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] + set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] if {$m ni $a_exported_tails} { lappend a_exported_tails $m } @@ -3071,7 +4005,7 @@ tcl::namespace::eval punk::ns { set imported_commands [list] if {[namespace exists $nstemp]} { namespace delete $nstemp - } + } namespace eval $nstemp {} foreach e $a_exported_tails { set imported [apply {{tgtns func srcns pfx tmpns} { @@ -3151,13 +4085,13 @@ tcl::namespace::eval punk::ns { @id -id ::i+ @cmd -name "i+" -help\ "Display command help side by side" - @values - cmds -multiple 1 -help\ + @values + cmd -multiple 1 -help\ "Command names for which to show help info" } interp alias {} i+ {}\ .=args> punk::args::get_by_id ::i+ |argd>\ - .=>2 dict get values cmds |cmds>\ + .=>2 dict get values cmd |cmds>\ .=cmds>2 lmap c {i -return tableobject {*}$c} |objs>\ .=objs>2 lmap t {$t configure -show_vseps 0 -show_edge 1} |>\ .=objs>2 lmap t {$t print} |tables>\ @@ -3179,9 +4113,9 @@ tcl::namespace::eval punk::ns { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index d823a923..317fc9de 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -174,7 +174,7 @@ tcl::namespace::eval punk::packagepreference { set is_exact 1 } else { set pkg [lindex $args 1] - set vwant [lrange $args 2 end] ;#rare - but version can be a list of options + set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { #only one version - and it has a dash lassign [split [lindex $vwant 0] -] a b diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index a39fceaf..2ab1fb01 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -100,8 +100,12 @@ namespace eval punk::repo { subcommand -type string -choicecolumns 8 -choicegroups { "frequently used commands" {${$maincommands}} "" {${$othercmds}} - } + } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} }] + #-choiceinfo { + # add {{doctype punkargs}} + # diff {{doctype punkargs}} + #} return $result } @@ -112,7 +116,7 @@ namespace eval punk::repo { # @id -id ::punk::repo::fossil_proxy # @cmd -name fossil -help "fossil executable # " - # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}} # } ""] lappend PUNKARGS [list { @@ -129,7 +133,7 @@ namespace eval punk::repo { @dynamic @id -id "::punk::repo::fossil_proxy diff" @cmd -name "fossil diff" -help "fossil diff" - @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} + @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} } ""] lappend PUNKARGS [list { #todo - remove this comment - testing dynamic directive @@ -137,7 +141,7 @@ namespace eval punk::repo { @id -id "::punk::repo::fossil_proxy add" @cmd -name "fossil add" -help "fossil add " - @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} } ""] #TODO #lappend PUNKARGS [list { @@ -145,7 +149,7 @@ namespace eval punk::repo { # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @cmd -name "fossil add" -help "fossil add # " - # @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # } ""] lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm index 99bc359d..4ba74656 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip { expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) | ($hour << 11) | ($min << 5) | ($sec >> 1)} } - + punk::args::define { + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -help\ + "Walk the directory structure starting at base/<-subpath> + and return a list of the files and folders encountered. + Resulting paths are relative to base unless -resultrelative + is supplied. + Folder names will end with a trailing slash. + " + -resultrelative -optional 1 -help\ + "Resulting paths are relative to this value. + Defaults to the value of base. If empty string + is given to -resultrelative the paths returned + are effectively absolute paths." + -emptydirs -default 0 -type boolean -help\ + "Whether to include directory trees in the result which had no + matches for the given fileglobs. + Intermediate dirs are always returned if there is a match with + fileglobs further down even if -emptdirs is 0. + " + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" -help\ + "May contain glob chars for folder elements" + @values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } proc walk {args} { #*** !doctools #[call [fun walk] [arg ?options?] [arg base]] #[para] Walk a directory tree rooted at base #[para] the -excludes list can be a set of glob expressions to match against files and avoid - #[para] e.g + #[para] e.g #[example { # punk::zip::walk -exclude {CVS/* *~.#*} library #}] #todo: -relative 0|1 flag? - set argd [punk::args::get_dict { - @id -id ::punk::zip::walk - @cmd -name punk::zip::walk -help\ - "Walk the directory structure starting at base/<-subpath> - and return a list of the files and folders encountered. - Resulting paths are relative to base unless -resultrelative - is supplied. - Folder names will end with a trailing slash. - " - -resultrelative -optional 1 -help\ - "Resulting paths are relative to this value. - Defaults to the value of base. If empty string - is given to -resultrelative the paths returned - are effectively absolute paths." - -emptydirs -default 0 -type boolean -help\ - "Whether to include directory trees in the result which had no - matches for the given fileglobs. - Intermediate dirs are always returned if there is a match with - fileglobs further down even if -emptdirs is 0. - " - -excludes -default "" -help "list of glob expressions to match against files and exclude" - -subpath -default "" -help\ - "May contain glob chars for folder elements" - @values -min 1 -max -1 - base - fileglobs -default {*} -multiple 1 - } $args] + set argd [punk::args::parse $args withid ::punk::zip::walk] set base [dict get $argd values base] set fileglobs [dict get $argd values fileglobs] set subpath [dict get $argd opts -subpath] @@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip { + punk::args::define { + @id -id ::punk::zip::Addentry + @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + @opts + -comment -default "" -help "An optional comment specific to the added file" + @values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } + # Addentry - was Mkzipfile -- # # FIX ME: should handle the current offset for non-seekable channels @@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip { #[para] You can provide a -comment for the file. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. - set argd [punk::args::get_dict { - @id -id ::punk::zip::Addentry - @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' - return a central directory file record" - @opts - -comment -default "" -help "An optional comment specific to the added file" - @values -min 3 -max 4 - zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" - base -help "base path for entries" - path -type file -help "path of file to add" - zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe - Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::Addentry] set zipchan [dict get $argd values zipchan] set base [dict get $argd values base] set path [dict get $argd values path] @@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip { # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) #### + + punk::args::define { + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" + @opts + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix. + " + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + " + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided. + Note that this will + " + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + + @values -min 1 -max -1 + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." + } + # zip::mkzip -- # # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt - # + # proc mkzip {args} { #todo - doctools - [arg ?globs...?] syntax? @@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip { #[para] If a file already exists, an error will be raised. #[para] Call 'punk::zip::mkzip' with no arguments for usage display. - set argd [punk::args::get_dict { - @id -id ::punk::zip::mkzip - @cmd -name punk::zip::mkzip\ - -help "Create a zip archive in 'filename'" - @opts - -offsettype -default "archive" -choices {archive file}\ - -help "zip offsets stored relative to start of entire file or relative to start of zip-archive - Only relevant if the created file has a script/runtime prefix. - " - -return -default "pretty" -choices {pretty list none}\ - -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none\ - -help "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs - " - -runtime -default ""\ - -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review) - " - -comment -default ""\ - -help "An optional comment for the archive" - -directory -default ""\ - -help "The new zip archive will scan for contents within this folder or current directory if not provided. - Note that this will - " - -base -default ""\ - -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" - -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - - @values -min 1 -max -1 - filename -type file -default ""\ - -help "name of zipfile to create" - globs -default {*} -multiple 1\ - -help "list of glob patterns to match. - Only directories with matching files will be included in the archive." - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::mkzip] set filename [dict get $argd values filename] if {$filename eq ""} { error "mkzip filename cannot be empty string" 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 9f4e75ee..ebd18fc1 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 @@ -140,16 +140,18 @@ tcl::namespace::eval textblock { # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # "algorithm choice" - - punk::args::define { - @dynamic - @id -id ::textblock::use_hash - @cmd -name "textblock::use_hash" -help\ - "Hashing algorithm to use for framecache lookup. - 'none' may be slightly faster but less compact - when viewing textblock::framecache" - @values -min 0 -max 1 - hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} + namespace eval argdoc { + set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]} + punk::args::define { + @dynamic + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP} + } } proc use_hash {args} { #set argd [punk::args::get_by_id ::textblock::use_hash $args] @@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock { -size -type integer\ -default 15\ -optional 1\ - -range {1 15} + -range {1 ""} -direction -default horizontal\ -choices {horizontal vertical}\ -help\ - "When rainbow is in the colour list, - this also affects the direction of - colour changes" - @values -min 0 -max 2 + "Direction of character increments. + When rainbow is in the colour list, + the colour stripes will be oriented + in this direction. + " + @values -min 0 -max 1 colour -type list -default {} -optional 1 -help\ "List of Ansi colour names - e.g. testblock 10 {white Red} + e.g. testblock -size 10 {white Red} produces a block of character 10x10 with white text on red bacground @@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock { set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + if {$size <= 15} { + set charsubset [lrange $chars 0 $size-1] + } else { + set numsets [expr {int(ceil($size / 15.0))}] + set longset [concat {*}[lrepeat $numsets $chars]] + set charsubset [lrange $longset 0 $size-1] + + set longbows [concat {*}[lrepeat $numsets $rainbow_list]] + set rainbow_list [lrange $longbows 0 $size-1] + } if {"noreset" in $colour} { set RST "" } else { @@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock { append row $c } append row $RST - append block $row\n + append block $row \n } set block [tcl::string::trimright $block \n] return $block } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST + if {$direction eq "vertical"} { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block + } else { + set block "" + for {set r 0} {$r < $size} {incr r} { + append block [::join $charsubset ""] \n + } + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block } - return $block } } interp alias {} testblock {} textblock::testblock @@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock { proc ::textblock::join1 {args} { - lassign [punk::args::get_dict { + lassign [punk::args::parse $args withdef { + @id -id ::textblock::join1 -ansiresets -default 1 -type integer blocks -type string -multiple 1 - } $args] _l leaders _o opts _v values + }] _l leaders _o opts _v values set blocks [tcl::dict::get $values blocks] set idx 0 @@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock { #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner #" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::textblock::join_basic2 -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -ansiresets -type any -default auto blocks -type any -multiple 1 - } $args] + }] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock { #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #they may however still be 'ragged' ie differing line lengths proc ::textblock::join {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - #-ansireplays is always on (if ansi detected) #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets @@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock { } proc ::textblock::join2 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock { } # This calls textblock::pad per cell :/ proc ::textblock::join3 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock { NOTE: more options available - argument definition is incomplete" @opts - -return -choices {table tableobject} + -return -default table -choices {table tableobject} -rows -type list -default "" -help\ "A list of lists. Each toplevel element represents a row. @@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock { -help "restrict to keys matching memberglob." }] #append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args + punk::args::parse $args withdef $spec return } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index 9809dc62..b73cbac8 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -2044,6 +2044,10 @@ if {[file exists $mapfile]} { } # -- --- --- --- --- --- --- --- --- --- puts "-- runtime_vfs_map --" +set ver [package require punk::args] +puts "punk::args ver: $ver" +set ifneeded [package ifneeded punk::args $ver] +puts "punk::args ifneeded: $ifneeded" punk::lib::pdict runtime_vfs_map puts "---------------------" puts "-- vfs_runtime_map--" diff --git a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm index 1ede846b..40366143 100644 --- a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application argparsingtest 0.1.0 # Meta platform tcl -# Meta license MIT +# Meta license MIT # @@ Meta End @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_argparsingtest 0 0.1.0] #[copyright "2024"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require argparsingtest] #[keywords module] #[description] @@ -106,7 +106,7 @@ namespace eval argparsingtest { #*** !doctools #[subsection {Namespace argparsingtest}] - #[para] Core API functions for argparsingtest + #[para] Core API functions for argparsingtest #[list_begin definitions] proc test1_ni {args} { @@ -277,8 +277,8 @@ namespace eval argparsingtest { #punk::args is slower than argp - but comparable, and argp doesn't support solo flags proc test1_punkargs {args} { set argd [punk::args::parse $args withdef { - @id -id ::argparsingtest::test1_punkargs - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -298,7 +298,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::test1_punkargs_by_id - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -320,7 +320,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::argparsingtest::test1_punkargs2 - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -334,7 +334,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -3 -default 3 -type integer @values - } + } proc test1_punkargs2 {args} { set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] return [tcl::dict::get $argd opts] @@ -342,9 +342,9 @@ namespace eval argparsingtest { proc test1_punkargs_validate_ansistripped {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs_validate_ansistripped - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string @@ -358,7 +358,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true @values - } $args] + }] return [tcl::dict::get $argd opts] } @@ -387,11 +387,11 @@ namespace eval argparsingtest { package require cmdline #cmdline::getoptions is much faster than typedGetoptions proc test1_cmdline_untyped {args} { - set cmdlineopts_untyped { - {return.arg "string" "return val"} + set cmdlineopts_untyped { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -405,11 +405,11 @@ namespace eval argparsingtest { return [::cmdline::getoptions args $cmdlineopts_untyped $usage] } proc test1_cmdline_typed {args} { - set cmdlineopts_typed { - {return.arg "string" "return val"} + set cmdlineopts_typed { + {return.arg "string" "return val"} {frametype.arg \uFFEF "frame type"} {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -465,7 +465,7 @@ namespace eval argparsingtest { #multiline values use first line of each record to determine amount of indent to trim proc test_multiline {args} { set t3 [textblock::frame t3] - set argd [punk::args::get_dict [subst { + set argd [punk::args::parse $args withdef [subst { -template1 -default { ****** * t1 * @@ -476,7 +476,7 @@ namespace eval argparsingtest { * t2 * ******} -template3 -default {$t3} - #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately + #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately -template3b -default { $t3 ----------------- @@ -491,20 +491,20 @@ namespace eval argparsingtest { " -flag -default 0 -type boolean - }] $args] + }]] return $argd } #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] - # return "ok" + # return "ok" #} @@ -524,14 +524,14 @@ namespace eval argparsingtest::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace argparsingtest::lib}] - #[para] Secondary functions that are part of the API + #[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 + # #[para]Description of utility1 + # return 1 #} @@ -549,17 +549,17 @@ namespace eval argparsingtest::lib { namespace eval argparsingtest::system { #*** !doctools #[subsection {Namespace argparsingtest::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide argparsingtest [namespace eval argparsingtest { variable pkg argparsingtest variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm index cf73c712..bd3f44bd 100644 --- a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm @@ -346,7 +346,7 @@ _+ +_ package require punk::args set standard_frame_types [textblock::frametypes] set argd [punk::args::parse $args withdef [tstr -return string { - @id -id ">punk . deck" + @id -id "::>punk . deck" @cmd -name "deck" -help "Punk Deck mascot" -frame -default arc -choices "${$standard_frame_types}" -choicerestricted 0 -choiceprefix 1 -boxmap -default {} -type dict diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 6908f4c3..8f971e3b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -6798,28 +6798,30 @@ namespace eval punk { return $linelist } - - punk::args::define { - @dynamic - @id -id ::punk::LOC - @cmd -name punk::LOC -help\ - "LOC - lines of code. - An implementation of a notoriously controversial metric" - -return -default showdict -choices {dict showdict} - -dir -default "\uFFFF" - -exclude_dupfiles -default 1 -type boolean - ${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]} - -antiglob_files -default "" -type list -help\ - "Exclude if file tail matches any of these patterns" - -exclude_punctlines -default 1 -type boolean - -show_largest -default 0 -type integer -help\ - "Report the top largest linecount files. - The value represents the number of files - to report on." - } " - #we could map away whitespace and use string is punct - but not as flexible? review - -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } - " + namespace eval argdoc { + set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]}} + punk::args::define { + @dynamic + @id -id ::punk::LOC + @cmd -name punk::LOC -help\ + "LOC - lines of code. + An implementation of a notoriously controversial metric" + -return -default showdict -choices {dict showdict} + -dir -default "\uFFFF" + -exclude_dupfiles -default 1 -type boolean + ${$DYN_ANTIGLOB_PATHS} + -antiglob_files -default "" -type list -help\ + "Exclude if file tail matches any of these patterns" + -exclude_punctlines -default 1 -type boolean + -show_largest -default 0 -type integer -help\ + "Report the top largest linecount files. + The value represents the number of files + to report on." + } " + #we could map away whitespace and use string is punct - but not as flexible? review + -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } + " + } #An implementation of a notoriously controversial metric. proc LOC {args} { set argd [punk::args::parse $args withid ::punk::LOC] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm index c7207cc0..fd638812 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm @@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore { smcup ::punk::console::enable_alt_screen\ rmcup ::punk::console::disable_alt_screen\ config ::punk::config\ + s ::punk::ns::synopsis\ ] #*** !doctools diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index f671311f..a7fe1047 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu foreach {pt code} $parts { switch -- [llength $codestack] { 0 { - append emit $base$pt$R + append emit $base $pt $R } 1 { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { - append emit $base$pt$R + append emit $base $pt $R set codestack [list] } else { #append emit [lindex $o_codestack 0]$pt if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } default { if {$fullmerge} { - append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R } else { - append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R + append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R } } } @@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append emit $code } } - return $emit$R + return [append emit $R] } else { return $base$text$R } 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 index da03207b..7f170ff4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.4.tm @@ -385,6 +385,7 @@ tcl::namespace::eval punk::args { a 'solo' flag ie accepts no value) int|integer list + indexexpression dict double bool|boolean @@ -423,7 +424,20 @@ tcl::namespace::eval punk::args { 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. + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. -choicerestricted Whether values not specified in -choices or -choicegroups are allowed. Defaults to true. @@ -439,12 +453,17 @@ tcl::namespace::eval punk::args { 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. + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). See for example the output if 'i zlib' where choices of the next subcommand are grouped by the names compression,channel, streaming and checksumming. The -choices list is equivalent to a -choicegroups dict entry where the key (groupname) is - the empty string. + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. -choicemultiple (default {1 1}) is a pair representing min and max number of choices that can be present in the value. @@ -1073,6 +1092,9 @@ tcl::namespace::eval punk::args { dict - dictionary { set v dict } + index { + set v indexexpression + } none - "" - - - any - ansistring - globstring - list { } @@ -1166,6 +1188,9 @@ tcl::namespace::eval punk::args { } list { + } + index { + set v indexexpression } default { #todo - disallow unknown types unless prefixed with custom- @@ -1258,6 +1283,9 @@ tcl::namespace::eval punk::args { } list { + } + index { + set v indexexpression } default { #todo - disallow unknown types unless prefixed with custom- @@ -1401,6 +1429,9 @@ tcl::namespace::eval punk::args { dict - dictionary { tcl::dict::set spec_merged -type dict } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } "" - none { if {$is_opt} { tcl::dict::set spec_merged -type none @@ -1837,7 +1868,14 @@ tcl::namespace::eval punk::args { lappend globbed {*}$matches } set globbed [lsort -unique $globbed] - set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] set result "" set resultdict [dict create] @@ -2431,13 +2469,16 @@ tcl::namespace::eval punk::args { @opts -badarg -type string -help\ "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" -aserror -type boolean -help\ "If true, the usage table is raised as an error message, otherwise it is returned as a value." -return -choices {string table tableobject} -choicelabels { string "no table layout" tableobject "table object cmd" - table "full table laout" + table "full table layout" } -scheme -default error -choices {nocolour info error} }] ] @@ -2496,15 +2537,32 @@ tcl::namespace::eval punk::args { set arg_error_isrunning 1 set badarg "" + set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error set scheme error dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme} $k] switch -- $fullk { -badarg { set badarg $v } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } -aserror { if {![string is boolean -strict $v]} { set arg_error_isrunning 0 @@ -2524,7 +2582,7 @@ tcl::namespace::eval punk::args { } default { set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return" } } } @@ -2547,6 +2605,8 @@ tcl::namespace::eval punk::args { set CLR(solo) [a+ brightcyan] set CLR(choiceprefix) [a+ underline] set CLR(badarg) [a+ brightred] + set CLR(goodarg) [a+ green strike] + set CLR(goodchoice) [a+ reverse] set CLR(linebase_header) [a+ white] set CLR(cmdname) [a+ brightwhite] set CLR(groupname) [a+ bold] @@ -2561,6 +2621,7 @@ tcl::namespace::eval punk::args { set CLR(check) "" set CLR(solo) "" set CLR(badarg) [a+ reverse] ;#? experiment + set CLR(goodarg) [a+ strike] set CLR(cmdname) [a+ bold] set CLR(linebase_header) "" set CLR(linebase) "" @@ -2764,10 +2825,12 @@ tcl::namespace::eval punk::args { #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 + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead @@ -2823,10 +2886,14 @@ tcl::namespace::eval punk::args { #} set leading_val_names_display $leading_val_names set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues foreach argshow $argnames_display arg $argnames { set arginfo [dict get $spec_dict ARG_INFO $arg] @@ -2900,12 +2967,29 @@ tcl::namespace::eval punk::args { if {[dict exists $choicelabeldict $c]} { append cdisplay \n [dict get $choicelabeldict $c] } - dict lappend formattedchoices $groupname $cdisplay + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } } } } else { - set formattedchoices $choicegroups + #set formattedchoices $choicegroups #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $c] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $c] + } else { + dict lappend formattedchoices $groupname $c + } + } + } } } else { if {[catch { @@ -2946,7 +3030,14 @@ tcl::namespace::eval punk::args { if {[dict exists $choicelabeldict $c]} { append cdisplay \n [dict get $choicelabeldict $c] } - dict lappend formattedchoices $groupname $cdisplay + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } } } } errM]} { @@ -2961,11 +3052,27 @@ tcl::namespace::eval punk::args { if {[dict exists $choicelabeldict $c]} { append cdisplay \n [dict get $choicelabeldict $c] } - dict lappend formattedchoices $groupname $cdisplay + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } } } } else { - set formattedchoices $choicegroups + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $c] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $c] + } else { + dict lappend formattedchoices $groupname $c + } + } + } } } @@ -3082,10 +3189,17 @@ tcl::namespace::eval punk::args { $t add_row [list $argshow $typeshow $default $multiple $help] if {$arg eq $badarg} { $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG } } else { #review - formatting will be all over the shop due to newlines in typesshow, help set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } foreach ln [split $help \n] { append arghelp " $ln" \n } @@ -3169,13 +3283,15 @@ tcl::namespace::eval punk::args { Will usually match the command name" }] proc usage {args} { - lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received set id [dict get $values id] set real_id [real_id $id] if {$real_id eq ""} { error "punk::args::usage - no such id: $id" } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 } lappend PUNKARGS [list { @@ -3430,6 +3546,10 @@ tcl::namespace::eval punk::args { puts stderr "errorstyle debug not implemented" return -options [list -code error -errorcode $ecode] $msg } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } } } trap {PUNKARGS} {msg erropts} { append msg \n "Unexpected PUNKARGS error" @@ -4378,6 +4498,14 @@ tcl::namespace::eval punk::args { } } } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "Option $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks @@ -4719,13 +4847,115 @@ tcl::namespace::eval punk::args { return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] } - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} + proc forms {id} { + dict get [get_spec $id] form_names + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set form * + if {[lindex $args 0] eq "-form"} { + set arglist [lrange $args 2 end] + set form [lindex $args 1] + } else { + set arglist $args + } + if {[llength $arglist] == 0} { + error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + } + set id [lindex $arglist 0] + set cmdargs [lrange $arglist 1 end] + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + set syn "" + #todo - -multiple etc + foreach f $form_names { + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + if {[dict get $arginfo -optional]} { + append syn " ?$argname?" + } else { + append syn " $argname" + } + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + append syn " ?$argname?..." + } else { + append syn " ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + append syn " ?$argname?" + } else { + append syn " ?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + append syn " $argname ?$argname...?" + } else { + append syn " $argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + append syn " $argname" + } else { + append syn " $argname <$tp>" + } + } + } + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + append syn " ?$argname?..." + } else { + append syn " ?$argname?" + } + } else { + if {[dict get $arginfo -multiple]} { + append syn " $argname ?$argname?..." + } else { + append syn " $argname" + } + } + } + append syn \n + } + return [string trim $syn \n] + } lappend PUNKARGS [list { @id -id ::punk::args::TEST diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.5.tm new file mode 100644 index 00000000..95e8011c --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.5.tm @@ -0,0 +1,6247 @@ +# -*- 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.5 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.5] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@argdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (text to replace autogenerated arg info) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED {}\ + 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} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + if {[lindex $args 0] eq "-dynamic"} { + set is_dynamic [lindex $args 1] + set textargs [lrange $args 2 end] + } + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $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 + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + 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 { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -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 { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -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 + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + 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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } 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] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso @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]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + }] ] + + #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 parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return" + } + } + } + #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(goodarg) [a+ green strike] + set CLR(goodchoice) [a+ reverse] + 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(goodarg) [a+ strike] + 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 + } else { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 80} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + append synopsis $form_synopsis \n + } + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + 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 arginfo [dict get $spec_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #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 + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $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 choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict {*}$definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + 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 + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {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] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + + + set 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 opts [dict create] ;#don't set to opt_defaults here + + + 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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 opts $opt_defaults + #--------------------------------------- + set ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $opt_defaults $o]} { + dict set ordered_opts $o [dict get $opt_defaults $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to val_defaults - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $val_defaults] + #------------------------------------------ + + 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_check -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_check -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_check -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 + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "Option $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "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 multis $multisreceived] + } + + + proc forms {id} { + dict get [get_spec $id] form_names + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::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.5 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.6.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.6.tm new file mode 100644 index 00000000..c3bf04b8 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.6.tm @@ -0,0 +1,6400 @@ +# -*- 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.6 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.6] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache $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_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + #set val_min $v + dict set F $fid VAL_MIN $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #now cycle through ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache $optionspecs $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set 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]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + #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::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + 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 parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + 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(goodarg) [a+ green strike] + set CLR(goodchoice) [a+ reverse] + 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(goodarg) [a+ strike] + 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 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $form_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $form_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + set id [lindex $tailargs 0] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + + 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-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } 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 + + #JJJJ + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$valmax == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $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 <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $valname_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $validx}] + } + #------------------------------------------ + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + 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 + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -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 + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer 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 + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.6 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.7.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.7.tm new file mode 100644 index 00000000..b04f4966 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.7.tm @@ -0,0 +1,6458 @@ +# -*- 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.7 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::args 0 0.1.7] +#[copyright "2024"] +#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[require punk::args] +#[keywords module proc args arguments parse] +#[description] +#[para]Utilities for parsing proc args + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). +#[para] overview of punk::args +#[subsection Concepts] +#[para]There are 2 main conventions for parsing a proc args list +#[list_begin enumerated] +#[enum] +#[para]leading option-value pairs and flags followed by a list of values (Tcl style) +#[enum] +#[para]leading list of values followed by option-value pairs and flags (Tk style) +#[list_end] +#[para]There are exceptions in both Tcl and Tk commands regarding this ordering +#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style +#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] +#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. +#[para] +#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g +#[example { +# proc dofilestuff {args} { +# lassign [dict values [punk::args::parse $args withdef { +# @cmd -help "do some stuff with files e.g dofilestuff " +# @opts -type string +# #comment lines ok +# -directory -default "" +# -translation -default binary +# #setting -type none indicates a flag that doesn't take a value (solo flag) +# -nocomplain -type none +# @values -min 1 -max -1 +# }]] leaders opts values +# +# puts "translation is [dict get $opts -translation]" +# foreach f [dict values $values] { +# puts "doing stuff with file: $f" +# } +# } +#}] +#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para]valid @ lines being with @cmd @leaders @opts @values +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. +#[para]e.g the result from the punk::args::parse call above may be something like: +#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments +#[para]This could also be implemented entirely using args - and the @leaders category of arguments +#[example { +# proc dofilestuff {category args} { +# lassign [dict values [punk::args::parse $args withdef { +# @id -id ::dofilestuff +# -directory -default "" +# -translation -default binary +# -nocomplain -type none +# @values -min 2 -max 2 +# fileA -type existingfile 1 +# fileB -type existingfile 1 +# }]] leaders opts values +# puts "$category fileA: [dict get $values fileA]" +# puts "$category fileB: [dict get $values fileB]" +# } +#}] +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para] or an additional call could be made to punk::args e.g +#[example { +# punk::args::parse [list $category $another_leading_arg] withdef { +# category -choices {cat1 cat2 cat3} +# another_leading_arg -type boolean +# } +#}] + +#*** !doctools +#[subsection Notes] +#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. +#[para] +#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. +#For functions that are part of an API a package may be more suitable. +#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) +#[example { +# proc test_switch {args} { +# set opts [dict create\\ +# -return "object"\\ +# -frametype "heavy"\\ +# -show_edge 1\\ +# -show_seps 0\\ +# -x a\\ +# -y b\\ +# -z c\\ +# -1 1\\ +# -2 2\\ +# -3 3\\ +# ] +# foreach {k v} $args { +# switch -- $k { +# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { +# dict set opts $k $v +# } +# default { +# error "unrecognised option '$k'. Known options [dict keys $opts]" +# } +# } +# } +# return $opts +# } +#}] +#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. +#[para] +# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. +# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. +#[para]use punk::lib::show_jump_tables to verify that a jump table exists. +#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous +#[example { +# proc test_prefix {args} { +# set opts [dict create\ +# -return string\ +# -frametype \uFFEF\ +# -show_edge \uFFEF\ +# -show_seps \uFFEF\ +# -x a\ +# -y b\ +# -z c\ +# -1 1\ +# -2 2\ +# -3 3\ +# ] +# if {[llength $args]} { +# set knownflags [dict keys $opts] +# } +# foreach {k v} $args { +# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v +# } +# return $opts +# } +#}] +#[para]There are many alternative args parsing packages a few of which are listed here. +#[list_begin enumerated] +#[enum]argp (pure tcl) +#[enum]parse_args (c implementation) +#[enum]argparse (pure tcl *) +#[enum]cmdline (pure tcl) +#[enum]opt (pure tcl) distributed with Tcl but considered deprecated +#[enum]The tcllib set of TEPAM modules (pure tcl) +#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. +#[list_end] +#[para] (* c implementation planned/proposed) +#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. +#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences +#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. +#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. +#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +#All ensemble commands are slower in a safe interp as they aren't compiled the same way +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. +#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) +#ensembles: array binary clock dict info namespace string +#possibly file too, although that is generally hidden/modified in a safe interp +#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc +#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::args +#[list_begin itemized] +package require Tcl 8.6- +#optional? punk::trie +#optional? punk::textblock +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +tcl::namespace::eval punk::args::register { + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] cooperative namespace punk::args::register + #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded + #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. + #[list_begin definitions] + + #Although the actual punk::args::define calls are not too sluggish, there could be *many*. + #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, + #especially since a fair proportion may be for documentation purposes rather than parsing args. + + # -- --- --- --- --- --- --- --- + #cooperative with packages that define some punk args but do so lazily + #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first + variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective + if {![info exists ::punk::args::register::NAMESPACES]} { + set ::punk::args::register::NAMESPACES [list] + } + # -- --- --- --- --- --- --- --- + + variable loaded_packages + if {![info exists loaded_packages]} { + set loaded_packages [list] ;#fully loaded + } + variable loaded_info + if {![info exists loaded_info]} { + set loaded_info [dict create] ;#time + } + variable scanned_packages + if {![info exists scanned_packages]} { + set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages + } + variable scanned_info ;#time and idcount + if {![info exists scanned_info]} { + set scanned_info [dict create] + } + #some packages, e.g punk::args::tclcore document other namespaces. + #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources + variable namespace_docpackages + if {![info exists namespace_docpackages]} { + set namespace_docpackages [dict create] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::register ---}] +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args { + + + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. + + tcl::namespace::export {[a-z]*} + variable rawdef_cache + if {![info exists rawdef_cache]} { + set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} + } + variable id_cache_rawdef + if {![info exists id_cache_rawdef]} { + set id_cache_rawdef [tcl::dict::create] + } + variable id_cache_spec + if {![info exists id_cache_spec]} { + set id_cache_spec [tcl::dict::create] + } + + variable argdefcache_unresolved + if {![info exists argdefcache_unresolved]} { + set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + } + + variable argdata_cache + if {![info exists argdata_cache]} { + set argdata_cache [tcl::dict::create] + } + + variable id_counter + if {![info exists id_counter]} { + set id_counter 0 + } + + #*** !doctools + #[subsection {Namespace punk::args}] + #[para] Core API functions for punk::args + #[list_begin definitions] + + #todo - some sort of punk::args::cherrypick operation to get spec from an existing set + #todo - doctools output from definition + + + + + #todo? -synonym/alias ? (applies to opts only not values) + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix + #e.g + # -corner -aliases {-corners} + # -centre -aliases {-center -middle} + #We mightn't want the prefix to be longer just because of an alias + #we should get -co -ce and -m from the above as abbreviations + + set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] + + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::define + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::define -help\ + "Accepts a line-based definition of command arguments. + The definition can be supplied as a single text block or multiple as described + in the help information for 'text' below. + + Returns an id which is a key to the stored definition. + The id is taken from the supplied definition's @id -id line, or is an + automatically created id of the form 'autoid_'. + + At the time define is called - just the raw text arguments are stored for the id. + When the id is first used, for example with 'punk::args::parse $args withid $id', + the raw definition is parsed into a stored specifications dictionary. + + This specifications dictionary is structured for (optional) use within commands to + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. + + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + and for synopsis generation with: s ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level beginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing, defaults for subsequent arguments, and help display. + directives include: + %B%@id%N% ?opt val...? + directive-options: -id + %B%@cmd%N% ?opt val...? + directive-options: -name -help + %B%@leaders%N% ?opt val...? + directive-options: -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + directive-options: -any + %B%@values%N% ?opt val...? + directive-options: -min -max + (used for trailing args that come after switches/opts) + %B%@form%N% ?opt val...? + directive-options: -form -synopsis + (used for commands with multiple forms) + The -synopsis value allows overriding the auto-calculated + synopsis. + %B%@formdisplay%N% ?opt val...? + directive-options: -header (text for header row of table) + -body (override autogenerated arg info for form) + %B%@doc%N% ?opt val...? + directive-options: -name -url + %B%@seealso%N% ?opt val...? + directive-options: -name -url (for footer - unimplemented) + + Some other options normally present on custom arguments are available + to use with the @leaders @opts @values directives to set defaults + for subsequent lines that represent your custom arguments. + These 3 directives should occur in exactly this order - but can be + repeated with custom argument lines interspersed. + + An @id line can only appear once and should be the first item. + For the commandline usage to be displayed either on parsing error + or using the i .. function - an @id with -id is needed. + + All directives can be omitted, in which case every line represents + a custom leader, value or option. + All will be leaders by default if no options defined. + If options are defined (by naming with leading dash, or explicitly + specifying @opts) then the definitions prior to the options will be + categorised as leaders, and those following the options will be + categorised as values. + + Custom arguments are defined by using any word at the start of a + line that doesn't begin with @ or - + (except that adding an additionl @ escapes this restriction so + that @@somearg becomes an argument named @somearg) + + custom leading args, switches/options (names starting with -) + and trailing values also take spec-options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + indexexpression + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + For non flag/switch arguments - all arguments with + -optional true must sit consecutively within their group. + ie all optional leader arguments must be together, and all + optional value arguments must be together. Furthermore, + specifying both optional leaders and optional values will + often lead to ambiguous parsing results. Currently, all + optional non-flg/switch arguments should be either at the + trailing end of leaders or the trailing end of values. + Further unambiguous arrangements of optional args may be + made in future - but are currently considered 'unsupported' + -default + -multiple (for leaders & values defines whether + subsequent received values are stored against the same + argument name - only applies to final leader OR final value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - not necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. If all choices are specified in values + within the -choicegroups dict, it is not necessary to specify them + in the -choices list. It is effectively a simpler form of + specifying choices when no grouping is required. It is fine to + use both -choices and -choicegroups e.g specifying all in -choices + and then including only some that need grouping in -choicegroups. + -choicelabels {} + keys are the values/argument names from -choices (or equivalently + members of value entries from the -choicegroups dict) + The values in the choicelabels dict are text values, possibly + containing newlines, that are displayed below each choice. + This is commonly a very basic summary of the choice. In the + case of a subcommand it may be a usage synopsis for further + arguments. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name (or the empty + string for 'ungrouped' items which appear first). + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. Both may be specified, in which case the + final list of available choices will be a union of the listed + values in -choices and the values from each choice group. + Choice values specified in -choices are effectively ungrouped + unless overridden by placing them in a choicegroup. + -choicemultiple (default {1 1}) + is a pair representing min and max number of choices + that can be present in the value. + If is a single integer it is equivalent to a + specified with the same integer for both min and max. + Max of -1 represents no upper limit. + If allows more than one choice the value is a list + consisting of items in the choices made available through + entries in -choices/-choicegroups. + -minsize (type dependant) + -maxsize (type dependant) + -range (type dependant) + + + " + -dynamic -type boolean -default 0 -help\ + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + are re-evaluated on each call. + If the definition is being used not just as documentation, but is also + used within the function to parse args, e.g using punk::args::get_by_id, + then it should be noted that there is a slight performance penalty for the + dynamic case. + It is often not significant, perhaps depending on what vars/commands are + used but -dynamic true might be less desirable if the command is used in + inner loops in more performance-sensitive code. + " + @values -min 1 -max -1 + text -type string -multiple 1 -help\ + "Block(s) of text representing the argument definition for a command. + At least one must be supplied. If multiple, they are joined together with \\n. + Using multiple text arguments may be useful to mix curly-braced and double-quoted + strings to have finer control over interpolation when defining arguments. + (this can also be handy for sections that pull resolved definition lines + from existing definitions (by id) for re-use of argument specifications and help text) + + e.g the following definition passes 2 blocks as text arguments + definition { + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ + \"Description of command\" + + #The following option defines an option-value pair + -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 {}\ + -ensembleparameter 0\ + ] + set optspec_defaults [tcl::dict::create\ + -type string\ + -optional 1\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + -prefix 1\ + ] + set valspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -choicemultiple {1 1}\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] + + #form record can have running entries such as 'argspace' that aren't given to arg parser + #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict + return [dict create\ + argspace "leaders"\ + ARG_INFO [tcl::dict::create]\ + ARG_CHECKS [tcl::dict::create]\ + LEADER_DEFAULTS [tcl::dict::create]\ + LEADER_REQUIRED [list]\ + LEADER_NAMES [list]\ + LEADER_MIN ""\ + LEADER_MAX ""\ + LEADERSPEC_DEFAULTS $leaderspec_defaults\ + LEADER_CHECKS_DEFAULTS {}\ + OPT_DEFAULTS [tcl::dict::create]\ + OPT_REQUIRED [list]\ + OPT_NAMES [list]\ + OPT_ANY 0\ + OPT_SOLOS {}\ + OPTSPEC_DEFAULTS $optspec_defaults\ + OPT_CHECKS_DEFAULTS {}\ + VAL_DEFAULTS [tcl::dict::create]\ + VAL_REQUIRED [list]\ + VAL_NAMES [list]\ + VAL_MIN ""\ + VAL_MAX ""\ + VALSPEC_DEFAULTS $valspec_defaults\ + VAL_CHECKS_DEFAULTS {}\ + FORMDISPLAY [tcl::dict::create]\ + ] + + } + + proc errorstyle {args} { + #set or query the running config -errorstyle + #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? + #values: + #debug, enhanced, standard, basic, minimal + error todo + } + proc define {args} { + variable rawdef_cache + variable id_cache_rawdef + variable argdata_cache + if {[dict exists $rawdef_cache $args]} { + return [dict get [dict get $rawdef_cache $args] -id] + } else { + set id [rawdef_id $args] + if {[id_exists $id]} { + #we seem to be re-creating a previously defined id... + #clear any existing caches for this id + puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" + + #dict unset argdata_cache $prevraw ;#silently does nothing if key not present + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + dict unset argdata_cache $k + } + } + dict for {k v} $rawdef_cache { + if {[dict get $v -id] eq $id} { + dict unset rawdef_cache $k + } + } + dict unset id_cache_rawdef $id + } + set is_dynamic [rawdef_is_dynamic $args] + set defspace [uplevel 1 {::namespace current}] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] + dict set id_cache_rawdef $id $args + return $id + } + } + + proc idquery_info {id} { + variable id_cache_rawdef + variable rawdef_cache + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache $rawdef]} { + set idinfo [dict get $rawdef_cache $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable argdata_cache + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $argdata_cache { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } + + proc define2 {args} { + dict get [resolve {*}$args] id + } + + proc resolve {args} { + variable rawdef_cache + variable id_cache_rawdef + set defspace "" + if {[dict exists $rawdef_cache $args]} { + set cinfo [dict get $rawdef_cache $args] + set id [dict get $cinfo -id] + set is_dynamic [dict get $cinfo -dynamic] + if {[dict exists $cinfo -defspace]} { + set defspace [dict get $cinfo -defspace] + } + } else { + #should we really be resolving something that hasn't been defined? + set id [rawdef_id $args] + puts stderr "Warning: punk::args::resolve called with undefined id:$id" + set is_dynamic [rawdef_is_dynamic $args] + dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] + dict set id_cache_rawdef $id $args + } + + + variable argdata_cache + variable argdefcache_unresolved + + + set cache_key $args + #ideally we would use a fast hash algorithm to produce a short key with low collision probability. + #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) + #review - check if there is a built-into-tcl way to do this quickly + #for now we will just key using the whole string + #performance seems ok - memory usage probably not ideal + #quote from DKF 2021 + #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. + #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. + #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. + #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). + #> If dealing with very large amounts of data, using a database is probably a good plan. + + set textargs $args + if {![llength $args]} { + punk::args::get_by_id ::punk::args::define {} + return + } + #if {[lindex $args 0] eq "-dynamic"} { + # set is_dynamic [lindex $args 1] + # set textargs [lrange $args 2 end] + #} + + #experimental + set LVL 2 + + if {!$is_dynamic} { + if {[tcl::dict::exists $argdata_cache $cache_key]} { + return [tcl::dict::get $argdata_cache $cache_key] + } + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + if {[string first \$\{ $optionspecs] > 0} { + if {$defspace ne ""} { + #normal/desired case + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } else { + #todo - deprecate/stop from happening? + puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" + set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + } + } else { + + if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + } else { + set normargs [list] + foreach a $textargs { + lappend normargs [tcl::string::map {\r\n \n} $a] + } + set optionspecs [join $normargs \n] + #dynamic - double substitution required. + #e.g + # set DYN_CHOICES {${[::somewhere::get_choice_list]}} + # set RED [punk::ansi::a+ bold red] + # set RST [punk::ansi::a] + # punk::args::define { + # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + #} + if {$defspace ne ""} { + set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + } + #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + if {[string first \$\{ $optionspecs] > 0} { + set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + lassign $pt_params ptlist paramlist + set optionspecs "" + foreach pt $ptlist param $paramlist { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } + tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } + } + #argdata_cache should be limited in some fashion or will be a big memory leak??? + if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { + #resolved cache version exists + return [tcl::dict::get $argdata_cache [list $optionspecs]] + } + } + + + + #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices + #default to 1 for convenience + + #checks with no default + #-minsize -maxsize -range + + + #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi + #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + + #set opt_defaults [tcl::dict::create] + #set val_defaults [tcl::dict::create] + + #set opt_solos [list] + #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end + + set records [list] + set linebuild "" + + set linelist [split $optionspecs \n] + set lastindent "" + foreach ln $linelist { + if {[tcl::string::trim $ln] eq ""} {continue} + regexp {(\s*).*} $ln _all lastindent + break ;#break at first non-empty + } + #puts "indent1:[ansistring VIEW $lastindent]" + set in_record 0 + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + foreach rawline $linelist { + set recordsofar [tcl::string::cat $linebuild $rawline] + #ansi colours can stop info complete from working (contain square brackets) + #review - when exactly are ansi codes allowed/expected in record lines. + # - we might reasonably expect them in default values or choices or help strings + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" + # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket + if {$has_punkansi} { + set test_complete [punk::ansi::ansistrip $recordsofar] + } else { + #review + #we only need to strip enough to stop interference with 'info complete' + set test_complete [string map [list \x1b\[ ""] $recordsofar] + } + if {![tcl::info::complete $test_complete]} { + #append linebuild [string trimleft $rawline] \n + if {$in_record} { + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. + #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. + #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) + #(note string first "" $str is fast and returns -1) + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline \n + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline \n + } else { + append linebuild $rawline \n + } + } else { + set in_record 1 + regexp {(\s*).*} $rawline _all lastindent + #puts "indent: [ansistring VIEW -lf 1 $lastindent]" + #puts "indent from rawline:$rawline " + append linebuild $rawline \n + } + } else { + set in_record 0 + #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left + if {[tcl::string::first "$lastindent " $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] + append linebuild $trimmedline + } elseif {[tcl::string::first $lastindent $rawline] == 0} { + set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] + append linebuild $trimmedline + } else { + append linebuild $rawline + } + lappend records $linebuild + set linebuild "" + } + } + set cmd_info {} + set package_info {} + set id_info {} ;#e.g -children ?? + set doc_info {} + #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table + set seealso_info {} + set keywords_info {} + ###set leader_min 0 + ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #set leader_max "" + #(common case of no leaders specified) + #set opt_any 0 + #set val_min 0 + #set val_max -1 ;#-1 for no limit + set DEF_definition_id $id + + #form_defs + set F [dict create _default [New_command_form _default]] + set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under + + #set ARGSPACE [dict create] ;#keyed on form + #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values + + set refs [dict create] + set record_type "" + set record_number -1 ;# + foreach rec $records { + set trimrec [tcl::string::trim $rec] + switch -- [tcl::string::index $trimrec 0] { + "" - # {continue} + } + incr record_number + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + if {[llength $record_values] % 2 != 0} { + #todo - avoid raising an error - store invalid defs keyed on id + error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" + } + # ---------------------------------------------------------- + # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. + #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! + #(form_ids_active is otherwise set in the @form handling block) + + #consider the following 2 line entry which is potentially dynamically included via a tstr: + # @form -form {* newform} + # @form -form {newform} -synopsis "cmd help ?stuff?" + #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. + #(because _default is usually 'taken over' by the first encountered form id) + #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record + #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. + + if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { + set patterns [dict get $record_values -form] + set record_form_ids [list] + foreach p $patterns { + if {[regexp {[*?\[\]]} $p]} { + #isglob - only used for matching existing forms + lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] + } else { + #don't test for existence - will define new form if necessary + lappend record_form_ids $p + } + } + #-form values could be globs that didn't match. record_form_ids could be empty.. + if {[llength $record_form_ids]} { + #only rename _default if it's the sole entry + if {[dict size $F] == 1 && [dict exists $F "_default"]} { + if {"_default" ni $record_form_ids} { + #only initial form exists - but we are mentioning new ones + #first rename the _default to first encountered new form id + #(just replace whole dict with new key - same data) + set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] + #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F + #we are only setting active because of the rename - @form is the way to change active forms list + set form_ids_active [lindex $record_form_ids 0] + } + } + foreach fid $record_form_ids { + if {![dict exists $F $fid]} { + if {$firstword eq "@form"} { + #only @form directly supplies keys + dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] + } else { + dict set F $fid [New_command_form $fid] + } + } else { + #update form with current record opts, except -form + if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } + } + } + } + } else { + #missing or empty -form + set record_form_ids $form_ids_active + if {$firstword eq "@form"} { + foreach fid $form_ids_active { + dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] + } + } + } + # ---------------------------------------------------------- + + set firstchar [tcl::string::index $firstword 0] + set secondchar [tcl::string::index $firstword 1] + if {$firstchar eq "@" && $secondchar ne "@"} { + set record_type "directive" + set directive_name $firstword + set at_specs $record_values + + switch -- [tcl::string::range $directive_name 1 end] { + dynamic { + set is_dynamic 1 + } + id { + #disallow duplicate @id line ? + #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) + + #id An id will be allocated if no id line present or the -id value is "auto" + + if {[dict exists $at_specs -id]} { + set thisid [dict get $at_specs -id] + if {$thisid ni [list $id auto]} { + error "punk::args::define @id mismatch existing: $id vs $thisid" + } + } + set id_info $at_specs + } + ref { + #a reference within the definition + #e.g see punk::args::tclcore ::after + #global reference dict - independent of forms + #ignore refs without an -id + #store all keys except -id + #complete overwrite if refid repeated later on + if {[dict exists $at_specs -id]} { + dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] + } + } + default { + #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple + #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) + #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) + #That is possibly too complicated and/or unnecessary? + #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? + + if {[dict exists $at_specs -id]} { + set copyfrom [get_spec [dict get $at_specs -id]] + #we don't copy the @id info from the source + #for now we only copy across if nothing set.. + #todo - bring across defaults for empty keys at targets? + #need to keep it simple enough to reason about behaviour easily.. + if {[dict size $copyfrom]} { + if {![dict size $cmd_info]} { + set cmd_info [dict get $copyfrom cmd_info] + } + if {![dict size $doc_info]} { + set doc_info [dict get $copyfrom doc_info] + } + + #foreach fid $record_form_ids { + # #only use elements with matching form id? + # #probably this feature mainly useful for _default anyway so that should be ok + # #cooperative doc sets specified in same file could share via known form ids too + # FORMDISPLAY has keys -header -body + # if {![dict size $F $fid $FORMDISPLAY]} { + # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { + # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] + # } + # } + # #TODO + # #create leaders opts vals depending on position of @default line? + # #options on @default line to exclude/include sets??? + #} + } + } + } + form { + # arity system ? + #handle multiple parsing styles based on arities and keyword positions (and/or flags?) + #e.g see lseq manual with 3 different parsing styles. + #aim to produce a table/subtable for each + # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ + # -arities { + # 2 + # {3 anykeys {1 .. 1 to}} + # {4 anykeys {3 by}} + # {5 anykeys {1 .. 1 to 3 by}} + # }\ + # -fallback 1 + # ... + # @parser -synopsis "start 'count' count ??'by'? step?"\ + # -arities { + # {3 anykeys {1 count}} + # } + # ... + # @form -synopsis "count ?'by' step?"\ + # -arities { + # 1 + # {3 anykeys {1 by}} + # } + # + # see also after manual + # @form -arities {1} + # @form -arities { + # 1 anykeys {0 info} + # } + #todo + + #can we generate a form synopsis if -synopsis not supplied? + + #form id can be list of ints|names?, or * + if {[dict exists $at_specs -form]} { + set idlist [dict get $at_specs -form] + if {$idlist eq "*"} { + #* only applies to form ids that exist at the time + set idlist [dict keys $F] + } + set form_ids_active $idlist + } + #new form keys already created if they were needed (done for all records that have -form ) + } + package { + set package_info [dict merge $package_info $at_specs] + } + cmd { + #allow arbitrary - review + set cmd_info [dict merge $cmd_info $at_specs] + } + doc { + set doc_info [dict merge $doc_info $at_specs] + } + formdisplay { + #override the displayed argument table for the form. + #(formdisplay keys -header -body) + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + foreach fid $record_form_ids { + tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] + } + } + opts { + foreach fid $record_form_ids { + if {[tcl::dict::get $F $fid argspace] eq "values"} { + error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" + } + tcl::dict::set F $fid argspace "options" + set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -any - + -anyopts { + #set opt_any $v + tcl::dict::set F $fid OPT_ANY $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { + #review - only apply to certain types? + tcl::dict::set tmp_optspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_optspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + index { + set v indexexpression + } + none - "" - - - any - ansistring - globstring - list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_optspec_defaults -type $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple - + -prefix { + #allow overriding of defaults for options that occur later + tcl::dict::set tmp_optspec_defaults $k $v + } + default { + set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" + } + } + } + tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults + } ;# end foreach record_form_ids + } + leaders { + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] in [list options values]} { + error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" + } + set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MIN $v + #if {$leader_max == 0} { + # set leader_max -1 + #} + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" + } + dict set F $fid LEADER_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -choiceinfo { + if {[llength $v] %2 != 0} { + error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_leaderspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_leaderspec_defaults $k $v + } + -ensembleparameter { + #review + tcl::dict::set tmp_leaderspec_defaults $k $v + #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults + + } ;#end foreach record_form_ids + + } + values { + foreach fid $record_form_ids { + dict set F $fid argspace "values" + + set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] + + foreach {k v} $at_specs { + switch -- $k { + -form { + #review - handled above + } + -min - + -minvalues { + if {$v < 0} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" + } + #set val_min $v + dict set F $fid VAL_MIN $v + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" + } + #set val_max $v + dict set F $fid VAL_MAX $v + } + -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set tmp_valspec_defaults $k $v + } + -choiceinfo - -choicegroups { + if {[llength $v] % 2 != 0} { + error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegroups ?? + if {$v} { + set k2 -[string range $k 3 end] ;#strip 'no' + tcl::dict::unset tmp_valspec_defaults $k2 + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + index { + set v indexexpression + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set tmp_valspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -regexprefailmsg - + -validationtransform - + -multiple { + tcl::dict::set tmp_valspec_defaults $k $v + } + default { + set known { -min -form -minvalues -max -maxvalues\ + -minsize -maxsize -range\ + -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase\ + -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + } + error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" + } + } + } + dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults + } + + } + seealso { + #todo! + #like @doc, except displays in footer, multiple - sub-table? + set seealso_info [dict merge $seealso_info $at_specs] + } + keywords { + #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? + set keywords_info [dict merge $keywords_info $at_specs] + } + default { + error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" + } + } + #record_type directive + continue + } elseif {$firstchar eq "-"} { + set argname $firstword + set argdef_values $record_values + tcl::dict::set argdef_values -ARGTYPE option + + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + dict set F $fid argspace "options" + } elseif {[dict get $F $fid argspace] eq "values"} { + error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" + } + set record_type option + dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] + #lappend opt_names $argname + } + + set is_opt 1 + } else { + set argname $firstword + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ + set argname [tcl::string::range $argname 1 end] + } + + set argdef_values $record_values + foreach fid $record_form_ids { + if {[dict get $F $fid argspace] eq "leaders"} { + set record_type leader + tcl::dict::set argdef_values -ARGTYPE leader + #lappend leader_names $argname + set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] + if {$argname ni $temp_leadernames} { + lappend temp_leadernames $argname + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + } else { + #This can happen if the definition has repeated values + error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + + if {[dict get $F $fid LEADER_MAX] >= 0} { + if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { + puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" + dict set F $fid LEADER_MAX [llength $temp_leadernames] + } + } + } else { + set record_type value + tcl::dict::set argdef_values -ARGTYPE value + set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] + if {$argname ni $temp_valnames} { + lappend temp_valnames $argname + tcl::dict::set F $fid VAL_NAMES $temp_valnames + } else { + error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" + } + #lappend val_names $argname + if {[dict get $F $fid VAL_MAX] >= 0} { + if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { + puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" + dict set F $fid VAL_MAX [llength $temp_valnames] + } + } + } + } + + set is_opt 0 + } + + + #assert - we only get here if it is a value or flag specification line. + #assert argdef_values has been set to the value of record_values + + foreach fid $record_form_ids { + if {$is_opt} { + set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] + } else { + if {[dict get $F $fid argspace] eq "values"} { + set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] + } else { + set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] + } + } + + # -> argopt argval + foreach {spec specval} $argdef_values { + #literal-key switch - bytecompiled to jumpTable + switch -- $spec { + -form { + + } + -type { + #normalize here so we don't have to test during actual args parsing in main function + switch -- [tcl::string::tolower $specval] { + int - integer { + tcl::dict::set spec_merged -type int + } + bool - boolean { + tcl::dict::set spec_merged -type bool + } + char - character { + tcl::dict::set spec_merged -type char + } + dict - dictionary { + tcl::dict::set spec_merged -type dict + } + index - indexexpression { + tcl::dict::set spec_merged -type indexexpression + } + "" - none { + if {$is_opt} { + tcl::dict::set spec_merged -type none + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } + } else { + #-solo only valid for flags + error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" + } + } + any - anything { + tcl::dict::set spec_merged -type any + } + ansi - ansistring { + tcl::dict::set spec_merged -type ansistring + } + any - string - globstring { + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + literal { + #value is the name of the argument + if {$is_opt} { + error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" + } + tcl::dict::set spec_merged -type literal + } + default { + #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW + tcl::dict::set spec_merged -type [tcl::string::tolower $specval] + } + } + } + -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 + } + -ensembleparameter { + #review - only leaders? + tcl::dict::set spec_merged $spec $specval + } + -prefix { + #for flags/options + tcl::dict::set spec_merged $spec $specval + } + -validationtransform { + #string is dict only 8.7/9+ + if {[llength $specval] % 2} { + error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" + } + dict for {tk tv} $specval { + switch -- $tk { + -function - -type - -minsize - -maxsize - -range { + } + default { + set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? + error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" + } + } + } + + } + default { + if {[string match ref-* $spec]} { + #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) + #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. + if {![tcl::dict::exists $refs $specval]} { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" + } else { + set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" + if {$targetswitch eq "-*"} { + set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id + } else { + if {[tcl::dict::exists $refs $specval $targetswitch]} { + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + } else { + puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" + } + } + } + } else { + set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ + -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ + -regexprepass -regexprefail -regexprefailmsg -validationtransform\ + -ensembleparameter\ + ] + error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" + } + } + } + } ;# end foreach {spec specval} argdef_values + + + if {$is_opt} { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + if {[tcl::dict::get $spec_merged -type] eq "none"} { + #JJJJ + dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] + } + } else { + tcl::dict::set F $fid ARG_CHECKS $argname\ + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + tcl::dict::set F $fid ARG_INFO $argname $spec_merged + #review existence of -default overriding -optional + if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + set temp_opt_required [dict get $F $fid OPT_REQUIRED] + lappend temp_opt_required $argname + dict set F $fid OPT_REQUIRED $temp_opt_required + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + set temp_leader_required [dict get $F $fid LEADER_REQUIRED] + lappend temp_leader_required $argname + dict set F $fid LEADER_REQUIRED $temp_leader_required + } else { + set temp_val_required [dict get $F $fid VAL_REQUIRED] + lappend temp_val_required $argname + dict set F $fid VAL_REQUIRED $temp_val_required + } + } + } + if {[tcl::dict::exists $spec_merged -default]} { + if {$is_opt} { + #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + if {[dict get $F $fid argspace] eq "leaders"} { + tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } else { + #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] + tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] + } + } + } + } ;# end foreach fid record_form_ids + + } ;# end foreach rec $records + + + #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { + # variable id_counter + # set DEF_definition_id "autoid_[incr id_counter]" + #} + + + #now cycle through ALL forms not just form_ids_active (record_form_ids) + dict for {fid formdata} $F { + # REVIEW + #no values specified - we can allow last leader to be multiple + foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" + } + } + + #todo - disallow any -multiple == true entries if any leaders have -multiple == true? + #(creates parsing ambiguity) + #ambiguity could be resolved if at least one required option/flag eg -- + #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type + #(overcomplex? todo see if any core/tcllib commands work like that) + + #only allow a single entry within VAL_NAMES to have -multiple == true + #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir + set val_multiples 0 + foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { + if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { + if {$val_multiples > 0} { + error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" + } + incr val_multiples + } + } + + #todo - document that ambiguities in API are likely if both @leaders and @values used + #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) + + + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + } + + + + + #todo - precalculate a set of 'arity' entries for each form + #We want a structure for the arg parser to get easy access and make a fast decision on which form applies + #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? + #1) after ms (1 1) + #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? + #3) after cancel id (2 2) + #4) after cancel script ?script...? (2 -1) + #5) after idle script ?script...? (1 -1) + #6) after info ?id? (1 2) + + #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) + + #in the above case we have no unique total_arity + #we would also want to consider values when selecting + #e.g given the invalid command "after cancel" + # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. + + + + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form + #e.g commandline completion could show list of synopsis entries to select from + + set form_info [dict create] + dict for {fid fdict} $F { + dict set form_info $fid {} + dict for {optk optv} $fdict { + if {[string match -* $optk]} { + dict set form_info $fid $optk $optv + } + } + } + + set argdata_dict [tcl::dict::create\ + id $DEF_definition_id\ + cmd_info $cmd_info\ + doc_info $doc_info\ + package_info $package_info\ + seealso_info $seealso_info\ + id_info $id_info\ + FORMS $F\ + form_names [dict keys $F]\ + form_info $form_info\ + ] + + tcl::dict::set argdata_cache $cache_key $argdata_dict + if {$is_dynamic} { + #also cache resolved version + tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict + } + + #tcl::dict::set id_cache_rawdef $DEF_definition_id $args + #puts "xxx:$result" + return $argdata_dict + } + + #return raw definition list as created with 'define' + # - possibly with unresolved dynamic parts + proc raw_def {id} { + variable id_cache_rawdef + set realid [real_id $id] + if {![dict exists $id_cache_rawdef $realid]} { + return "" + } + return [tcl::dict::get $id_cache_rawdef $realid] + } + + + namespace eval argdoc { + variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} + variable resolved_def_TYPE_CHOICEGROUPS { + directives {@id @package @cmd @ref @doc @formdisplay @seealso} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} + } + + lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { + @id -id ::punk::args::resolved_def + @cmd -name punk::args::resolved_def -help\ + "Resolves or retrieves the previously resolved definition and + uses the 'spec' form to build a response in definition format. + + Pulling argument definition data from another function is a form + of tight coupling to the other function that should be done with + care. + + Note that the directives @leaders @opts @values may appear multiple + times in a source definition - applying defaults for arguments that + follow. When retrieving these - there is only a single result for + each that represents the defaults after all have been applied. + When retrieving -types * each of these will be positioned before + the arguments of that type - but this doesn't mean there was a single + leading directive for this argument type in the source definition. + Each argument has already had its complete specification recorded in + its own result. + + When manually specifying -types, the order @leaders then @opts then + @values must be maintained - but if they are placed before their + corresponding arguments, they will not affect the retrieved arguments + as these arguments are already fully spec'd. The defaults from the + source can be removed by adding @leaders, @opts @values to the + -antiglobs list, but again - this won't affect the existing arguments. + Each argument can have members of its spec overridden using the + -override dictionary. + " + @leaders -min 0 -max 0 + @opts + -return -default text -choices {text dict} + -form -default 0 -help\ + "Ordinal index or name of command form" + + #no restriction on number of types/repetitions? + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -antiglobs -default {} -type list -help\ + "Glob patterns for directive or argument/flags to + be suppressed" + -override -type dict -optional 1 -default "" -help\ + "dict of dicts. Key in outer dict is the name of a + directive or an argument. Inner dict is a map of + overrides/additions (- ...) for that line. + " + @values -min 1 -max -1 + id -type string -help\ + "identifer for a punk::args definition + This will usually be a fully-qualifed + path for a command name" + pattern -type string -optional 1 -default * -multiple 1 -help\ + "glob-style patterns for retrieving value or switch + definitions. + + If -type is * and pattern is * the entire definition including + directive lines will be returned in line form. + (directives are lines beginning with + @ e.g @id, @cmd etc) + + if -type is leaders,opts or values matches from that type + will be returned. + + if -type is another directive such as @id, @doc etc the + patterns are ignored. + + " + }]] + } + + + proc resolved_def {args} { + #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. + set opts [dict create\ + -return text\ + -types {}\ + -form 0\ + -antiglobs {}\ + -override {}\ + ] + if {[llength $args] < 1} { + #must have at least id + punk::args::parse $args withid ::punk::args::resolved_def + return + } + set patterns [list] + + #a definition id must not begin with "-" ??? review + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {$a in {-type -types}} { + incr i + dict set opts -types [lindex $args $i] + } elseif {[string match -* $a]} { + incr i + dict set opts $a [lindex $args $i] + } else { + set id [lindex $args $i] + set patterns [lrange $args $i+1 end] + break + } + if {$i == [llength $args]-1} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + if {![llength $patterns]} { + set patterns [list *] + } + dict for {k v} $opts { + switch -- $k { + -return - -form - -types - -antiglobs - -override {} + default { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + } + set typelist [dict get $opts -types] + if {[llength $typelist] == 0} { + set typelist {*} + } + foreach type $typelist { + if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { + punk::args::parse $args withid ::punk::args::resolved_def + return + } + } + + + variable id_cache_rawdef + set realid [real_id $id] + if {$realid eq ""} { + return + } + + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + set formname [lindex [dict get $specdict form_names] $opt_form] + } else { + set formname $opt_form + } + set opt_override [dict get $opts -override] + set opt_return [dict get $opts -return] + + #set arg_info [dict get $specdict ARG_INFO] + set arg_info [dict get $specdict FORMS $formname ARG_INFO] + set argtypes [dict create leaders leader opts option values value] + + set opt_antiglobs [dict get $opts -antiglobs] + set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] + set suppressed_directives [list] + set suppressed_args [list] + foreach ag $opt_antiglobs { + foreach d $directives { + if {[string match $ag $d]} { + lappend suppressed_directives $d + } + } + foreach argname [dict keys $arg_info] { + if {[string match $ag $argname]} { + lappend suppressed_args $argname + } + } + } + set suppressed_directives [lsort -unique $suppressed_directives] + set suppressed_args [lsort -unique $suppressed_args] + + set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] + + set globbed [list] + foreach pat $patterns { + set matches [dict keys $arg_info $pat] + lappend globbed {*}$matches + } + set globbed [lsort -unique $globbed] + #maintain order of original arg_info keys in globbed results + set ordered_globbed [list] + foreach a [dict keys $arg_info] { + if {$a ni $ordered_globbed && $a in $globbed} { + lappend ordered_globbed $a + } + } + set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] + + set result "" + set resultdict [dict create] + foreach type $typelist { + switch -exact -- $type { + * { + if {"@id" in $included_directives} { + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + foreach directive {@package @cmd @doc @seealso} { + set dshort [string range $directive 1 end] + if {"$directive" in $included_directives} { + if {[dict exists $opt_override $directive]} { + append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict ${dshort}_info]" + dict set resultdict $directive [dict get $specdict ${dshort}_info] + } + } + } + + #todo @formdisplay + + + #output ordered by leader, option, value + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" + switch -- $directive { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + + if {"$directive" in $included_directives} { + if {[dict exists $opt_override "$directive"]} { + append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" + dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] + } else { + append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" + dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] + } + } + + if {$pseudodirective in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq $tp} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + + } + @id { + if {"@id" in $included_directives} { + #only a single id record can exist + if {[dict exists $opt_override @id]} { + append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" + dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] + } else { + append result \n "@id -id [dict get $specdict id]" + dict set resultdict @id [list -id [dict get $specdict id]] + } + } + } + @package - @cmd - @doc - @seealso { + if {"$type" in $included_directives} { + set tp [string range $type 1 end] ;# @package -> package + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict ${tp}_info]" + dict set resultdict $type [dict get $specdict ${tp}_info] + } + } + #todo @formdisplay + } + @leaders - @opts - @values { + #these are the active defaults for further arguments + if {"$type" in $included_directives} { + switch -- $type { + @leaders {set defaults_key LEADERSPEC_DEFAULTS} + @opts {set defaults_key OPTSPEC_DEFAULTS} + @values {set defaults_key VALSPEC_DEFAULTS} + } + if {[dict exists $opt_override $type]} { + append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" + dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] + } else { + append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" + dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] + } + } + } + leaders - opts - values { + #pseudo-directives + if {$type in $included_directives} { + foreach m $included_args { + set argspec [dict get $arg_info $m] + if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { + set argspec [dict remove $argspec -ARGTYPE] + if {[dict exists $opt_override $m]} { + append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" + dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] + } else { + append result \n "$m $argspec" + dict set resultdict $m $argspec + } + } + } + } + } + default { + } + } + if {$opt_return eq "text"} { + return $result + } else { + return $resultdict + } + } + } + + proc resolved_def_values {id {patternlist *}} { + variable id_cache_rawdef + set realid [real_id $id] + if {$realid ne ""} { + set deflist [tcl::dict::get $id_cache_rawdef $realid] + set specdict [resolve {*}$deflist] + set arg_info [dict get $specdict ARG_INFO] + set valnames [dict get $specdict VAL_NAMES] + set result "" + if {$patternlist eq "*"} { + foreach v $valnames { + set def [dict get $arg_info $v] + set def [dict remove $def -ARGTYPE] + append result \n "$v $def" + } + return $result + } else { + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + set matches [lsearch -all -inline -glob $valnames $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } + } + } + #proc resolved_def_leaders ?? + #proc resolved_def_opts ?? + + proc get_spec {id} { + set deflist [raw_def $id] + if {$deflist eq ""} { + return + } + return [resolve {*}$deflist] + #if {[id_exists $id]} { + # return [resolve {*}[raw_def $id]] + #} + } + proc is_dynamic {id} { + variable id_cache_rawdef + variable rawdef_cache + set deflist [raw_def $id] + if {[dict exists $rawdef_cache $deflist -dynamic]} { + return [dict get $rawdef_cache $deflist -dynamic] + } + return [rawdef_is_dynamic $deflist] + #@dynamic only has meaning as 1st element of a def in the deflist + } + + #@id must be within first 4 lines of a block - or assign auto + #review - @dynamic block where -id not explicitly set? - disallow? + proc rawdef_id {rawdef} { + set id "" + foreach d $rawdef { + foreach ln [lrange [split $d \n] 0 4] { + if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { + if {$firstword eq "@id"} { + if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { + set id [dict get $rest -id] + break + } + } + } + } + if {$id ne ""} { + break + } + } + if {$id eq "" || [string tolower $id] eq "auto"} { + variable id_counter + set id "autoid_[incr id_counter]" + } + #puts "==>id: $id" + return $id + } + #test the rawdef for @dynamic directive + proc rawdef_is_dynamic {rawdef} { + #temporary - old way + set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] + if {$flagged_dynamic} { + return true + } + foreach d $rawdef { + if {[regexp {\s*(\S+)} $d _match firstword]} { + if {$firstword eq "@dynamic"} { + return true + } + } + } + return false + } + + variable aliases + set aliases [dict create] + + lappend PUNKARGS [list { + @id -id ::punk::args::get_ids + @cmd -name punk::args::get_ids -help\ + "return list of ids for argument definitions" + @values -min 0 -max 1 + match -default * -help\ + "exact id or glob pattern for ids" + }] + proc get_ids {{match *}} { + variable id_cache_rawdef + variable aliases + return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] + } + + #we don't automatically test for (autodef)$id - only direct ids and aliases + proc id_exists {id} { + variable aliases + if {[tcl::dict::exists $aliases $id]} { + return 1 + } + variable id_cache_rawdef + tcl::dict::exists $id_cache_rawdef $id + } + proc set_alias {alias id} { + variable aliases + dict set aliases $alias $id + } + proc unset_alias {alias} { + variable aliases + dict unset aliases $alias + } + proc get_alias {alias} { + variable aliases + if {[dict exists $aliases $alias]} { + return [tcl::dict::get $aliases $alias] + } + } + + proc real_id {id} { + variable id_cache_rawdef + variable aliases + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } else { + set check_updates [list [namespace qualifiers $id]] + #puts stderr "---->real_id '$id' update_definitions $check_updates" + if {![llength [update_definitions $check_updates]]} { + #nothing new loaded + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } else { + if {[tcl::dict::exists $aliases $id]} { + set id [tcl::dict::get $aliases $id] + } + if {[tcl::dict::exists $id_cache_rawdef $id]} { + return $id + } + if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { + return (autodef)$id + } + return "" + } + } + } + + proc status {} { + upvar ::punk::args::register::NAMESPACES registered + upvar ::punk::args::register::loaded_packages loaded_packages + upvar ::punk::args::register::loaded_info loaded_info + upvar ::punk::args::register::scanned_packages scanned_packages + upvar ::punk::args::register::scanned_info scanned_info + set result "" + # [format %-${w0}s $idtail] + set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] + append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n + set width_c2 [string length "Scanned_ids"] + set width_c3 [string length "Scantime_us"] + set width_c4 [string length "Loaded_defs"] + set width_c5 [string length "Loadtime_us"] + set count_unloaded 0 + set count_loaded 0 + foreach ns $registered { + if {$ns in $scanned_packages} { + set ids [dict get $scanned_info $ns idcount] + set scan_us [dict get $scanned_info $ns time] + } else { + set ids "" + set scan_us "" + } + if {$ns in $loaded_packages} { + incr count_loaded + set ldefs [dict get $loaded_info $ns defcount] + set load_us [dict get $loaded_info $ns time] + } else { + incr count_unloaded + set ldefs "" + set load_us "" + } + append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n + } + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + return $result + } + + #scanned_packages (list) + #namespace_docpackages (dict) + proc update_definitions {{nslist *}} { + #puts "----> update_definitions '$nslist'" + if {[set gposn [lsearch $nslist {}]] >= 0} { + lset nslist $gposn :: + } + upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::loaded_packages loaded_packages ;#list + upvar ::punk::args::register::loaded_info loaded_info ;#dict + upvar ::punk::args::register::scanned_packages scanned_packages ;#list + upvar ::punk::args::register::scanned_info scanned_info ;#dict + upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict + + + #puts stderr "-->update_definitions '$nslist'" + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - gets called for each subcommand of an ensemble (could be many) + # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. + #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. + # -- --- --- --- --- --- + # common-case fast-path + + if {[llength $loaded_packages] == [llength $registered]} { + #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. + #assert - if all are registered - then all have been scanned + return {} + } + # -- --- --- --- --- --- + + set unscanned [punklib_ldiff $registered $scanned_packages] + if {[llength $unscanned]} { + foreach pkgns $unscanned { + set idcount 0 + set ts_start [clock microseconds] + if {[info exists ${pkgns}::PUNKARGS]} { + set seen_documentedns [list] ;#seen per pkgns + foreach definitionlist [set ${pkgns}::PUNKARGS] { + #namespace eval $evalns [list punk::args::define {*}$definitionlist] + set id [rawdef_id $definitionlist] + if {[string match autoid_* $id]} { + puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" + puts stderr "definition:\n" + foreach d $definitionlist { + set out "" + foreach ln [split $d \n] { + append out " " $ln \n + } + puts $out + } + continue + } + #todo - detect duplicate ids (last will silently win.. should be reported somewhere) + incr idcount + set documentedns [namespace qualifiers $id] + if {$documentedns eq ""} {set documentedns ::} + if {$documentedns ni $seen_documentedns} { + #don't add own ns as a key in namespace_docpackages + if {$documentedns ne $pkgns} { + dict lappend namespace_docpackages $documentedns $pkgns + } + lappend seen_documentedns $documentedns + } + } + } + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + dict set scanned_info $pkgns [dict create time $diff idcount $idcount] + #we count it as scanned even if PUNKARGS didn't exist + #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) + lappend scanned_packages $pkgns + } + } + + + + if {"*" in $nslist} { + set needed [punklib_ldiff $registered $loaded_packages] + } else { + set needed [list] + foreach pkgns $nslist { + if {![string match ::* $pkgns]} { + puts stderr "warning: update_definitions received unqualified ns: $pkgns" + set pkgns ::$pkgns + } + if {$pkgns in $registered && $pkgns ni $loaded_packages} { + lappend needed $pkgns + } + #argdoc sub namespace is a standard place to put defs that match the namespace below + #(generally the PUNKARGS in a namespace should apply to own ns) + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { + lappend needed $docns + } + } + if {[dict exists $namespace_docpackages $pkgns]} { + #this namespace has other argdef sources + foreach docns [dict get $namespace_docpackages $pkgns] { + if {$docns ni $loaded_packages} { + lappend needed $docns + } + } + } + } + } + + + + set newloaded [list] + foreach pkgns $needed { + #puts stderr "update_definitions Loading: $pkgns" + set ts_start [clock microseconds] + set def_count 0 + if {![catch { + if {[info exists ${pkgns}::PUNKARGS]} { + set docns ${pkgns}::argdoc + if {[namespace exists $docns]} { + namespace eval ${pkgns}::argdoc { + set epath [namespace path] + set pkgns [namespace parent] + if {$pkgns ni $epath} { + namespace path [list {*}$epath $pkgns] ;#add to tail + } + + } + set evalns $docns + } else { + set evalns $pkgns + } + foreach definitionlist [set ${pkgns}::PUNKARGS] { + namespace eval $evalns [list punk::args::define {*}$definitionlist] + incr def_count + } + } + + #process list of 2-element lists + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } + } errMsg]} { + set ts_end [clock microseconds] + set diff [expr {$ts_end - $ts_start}] + lappend loaded_packages $pkgns + lappend newloaded $pkgns + dict set loaded_info $pkgns [dict create time $diff defcount $def_count] + } else { + puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" + } + } + return $newloaded + } + + #for use within get_dict only + #This mechanism gets less-than-useful results for oo methods + #e.g {$obj} + proc Get_caller {} { + #set call_level -3 ;#for get_dict call + set call_level -4 + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" + while {[string last \n $cmdinfo] >= 1} { + #looks like a script - haven't gone up far enough? + #(e.g patternpunk oo system: >punk . poses -invalidoption) + incr call_level -1 + if {[catch { + set nextup [tcl::info::frame $call_level] + } ]} { + break + } + set cmdinfo [tcl::dict::get $nextup cmd] + set caller [regexp -inline {\S+} $cmdinfo] + if {[interp alias {} $caller] ne ""} { + #puts "found alias for caller $caller to [interp alias {} $caller]" + #see if we can go further + incr call_level -1 + if {[catch { + set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] + } errM ]} { + puts "err: $errM" + break + } + } + } + set caller [regexp -inline {\S+} $cmdinfo] + if {$caller eq "namespace"} { + # review - message? + set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" + } + return $cmdinfo + } + + + # -------------------------------------- + #test of Get_caller + lappend PUNKARGS [list { + @id -id ::punk::args::test1 + @values -min 0 -max 0 + }] + proc test_get_dict {args} { + punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args + } + proc test_get_by_id {args} { + punk::args::get_by_id ::punk::args::test1 $args + } + #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. + proc test_callers {args} { + if {![llength $args]} { + puts "these test functions accept no arguments" + puts "Call with arg(s) to compare error output" + } + + if {[catch {test_get_dict {*}$args} errM]} { + puts $errM + } + puts "------------" + if {[catch {test_get_by_id {*}$args} errM]} { + puts $errM + } + return done + } + # -------------------------------------- + + set map "" + lappend PUNKARGS [list [string map $map { + @id -id ::punk::args::arg_error + @cmd -name punk::args::arg_error -help\ + "Generates a table (by default) of usage information for a command. + A trie system is used to create highlighted prefixes for command + switches and for subcommands or argument/switch values that accept + a defined set of choices. These prefixes match the mechanism used + to validate arguments (based on tcl::prefix::match). + + This function is called during the argument parsing process + (if the definition is not only being used for documentation) + It is also called by punk::args::usage which is in turn + called by the punk::ns introspection facilities which creates + on the fly definitions for some commands such as ensembles and + oo objects where a manually defined one isn't present. + " + @leaders -min 2 -max 2 + msg -type string -help\ + "Error message to display immediately prior to usage table. + May be empty string to just display usage. + " + spec_dict -type dict -help\ + "Dictionary of argument specifications. + This is the internal format parsed from + the textual definition. It contains the data + organised/optimised to allow the final arg + parser/validator to make decisions. + " + @opts + -badarg -type string -help\ + "name of an argument to highlight" + -parsedargs -type dict -help\ + "Result of successful punk::pargs::parse + (currently only looks at 'received')" + -aserror -type boolean -help\ + "If true, the usage table is raised as an error message, + otherwise it is returned as a value." + -return -choices {string table tableobject} -choicelabels { + string "no table layout" + tableobject "table object cmd" + table "full table layout" + } + -scheme -default error -choices {nocolour info error} + -form -default 0 -help\ + "Ordinal index or name of command form" + }] ] + + if {[catch {package require punk::ansi}]} { + proc punk::args::a {args} {} + proc punk::args::a+ {args} {} + } else { + namespace eval ::punk::args { + namespace import ::punk::ansi::a ::punk::ansi::a+ + } + } + variable arg_error_CLR + array set arg_error_CLR {} + set arg_error_CLR(errormsg) [a+ brightred] + set arg_error_CLR(title) "" + set arg_error_CLR(check) [a+ brightgreen] + set arg_error_CLR(solo) [a+ brightcyan] + set arg_error_CLR(choiceprefix) [a+ underline] + set arg_error_CLR(badarg) [a+ brightred] + set arg_error_CLR(goodarg) [a+ green strike] + set arg_error_CLR(goodchoice) [a+ reverse] + set arg_error_CLR(linebase_header) [a+ white] + set arg_error_CLR(cmdname) [a+ brightwhite] + set arg_error_CLR(groupname) [a+ bold] + set arg_error_CLR(ansiborder) [a+ bold] + set arg_error_CLR(ansibase_header) [a+ bold] + set arg_error_CLR(ansibase_body) [a+ white] + variable arg_error_CLR_nocolour + array set arg_error_CLR_nocolour {} + set arg_error_CLR_nocolour(errormsg) [a+ bold] + set arg_error_CLR_nocolour(title) [a+ bold] + set arg_error_CLR_nocolour(check) "" + set arg_error_CLR_nocolour(solo) "" + set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment + set arg_error_CLR_nocolour(goodarg) [a+ strike] + set arg_error_CLR_nocolour(cmdname) [a+ bold] + set arg_error_CLR_nocolour(linebase_header) "" + set arg_error_CLR_nocolour(linebase) "" + set arg_error_CLR_nocolour(ansibase_body) "" + variable arg_error_CLR_info + array set arg_error_CLR_info {} + set arg_error_CLR_info(errormsg) [a+ brightred bold] + set arg_error_CLR_info(title) [a+ brightyellow bold] + set arg_error_CLR_info(check) [a+ brightgreen bold] + set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_info(groupname) [a+ cyan bold] + set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] + set arg_error_CLR_info(ansibase_header) [a+ cyan] + set arg_error_CLR_info(ansibase_body) [a+ white] + variable arg_error_CLR_error + array set arg_error_CLR_error {} + set arg_error_CLR_error(errormsg) [a+ brightred bold] + set arg_error_CLR_error(title) [a+ brightcyan bold] + set arg_error_CLR_error(check) [a+ brightgreen bold] + set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] + set arg_error_CLR_error(groupname) [a+ cyan bold] + set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] + set arg_error_CLR_error(ansibase_header) [a+ yellow] + set arg_error_CLR_error(ansibase_body) [a+ white] + + + #bas ic recursion blocker + variable arg_error_isrunning 0 + proc arg_error {msg spec_dict args} { + #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. + #accept an option here so that we can still use full output for usage requests. + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #Development/experimentation may be done with full table-based error reporting - but for production release it + #may be desirable to reduce overhead on catches. + #consider per-namespace or namespace-tree configurability. + #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due + #to resource availability etc - so the slower error generation time may not always be a problem. + #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling + #code which has no use for the enhanced error info. + #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #todo + #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + + #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} + #only |?-x?|string|... is shown in the output table. + #should be something like: + # |arg | + # |?-x? | + # |arg | + # |?arg...?| + # Where/how to specify counts? + #also.. + # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? + # + + + #limit colours to standard 16 so that themes can apply to help output + variable arg_error_isrunning + if {$arg_error_isrunning} { + error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" + } + + if {[llength $args] %2 != 0} { + error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" + } + + set arg_error_isrunning 1 + + set badarg "" + set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) + set goodargs [list] + set returntype table ;#table as string + set as_error 1 ;#usual case is to raise an error + set scheme error + set form 0 + dict for {k v} $args { + set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] + switch -- $fullk { + -badarg { + set badarg $v + } + -parsedargs { + #todo? + dict for {set setinfo} $v { + switch -- $set { + received { + foreach {r rpos} $setinfo { + if {$r ni $goodargs} { + lappend goodargs $r + } + } + } + } + } + set parsedargs $v + } + -aserror { + if {![string is boolean -strict $v]} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" + } + set as_error $v + } + -scheme { + set scheme $v + } + -return { + if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" + } + set returntype $v + } + -form { + set form $v + } + default { + set arg_error_isrunning 0 + error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" + } + } + } + #todo - scheme - use config and iterm toml definitions etc + switch -- $scheme { + "" - -nocolor - -nocolour { + set scheme nocolour + } + info - error {} + default { + set scheme na + } + } + set formnames [dict get $spec_dict form_names] + if {[string is integer -strict $form]} { + if {$form < 0 || $form > [llength $formnames]-1} { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + set selected_forms [list [lindex $formnames $form]] + } else { + if {$form eq "*"} { + set selected_forms $formnames + } else { + if {$form in $formnames} { + set selected_forms [list $form] + } else { + set arg_error_isrunning 0 + error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" + } + } + } + + + #hack some basics for now. + #for coloured schemes - use bold as well as brightcolour in case colour off. + upvar ::punk::args::arg_error_CLR CLR + + switch -- $scheme { + nocolour { + variable arg_error_CLR_nocolour + array set CLR [array get arg_error_CLR_nocolour + } + info { + variable arg_error_CLR_info + array set CLR [array get arg_error_CLR_info] + } + error { + variable arg_error_CLR_error + array set CLR [array get arg_error_CLR_error] + } + na { + } + } + + + #set RST [a] + set RST "\x1b\[m" + set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. + + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #e.g list_as_table + + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minsize -maxsize) + set errmsg $msg + if {![catch {package require textblock}]} { + set has_textblock 1 + } else { + set has_textblock 0 + #couldn't load textblock package + #just return the original errmsg without formatting + } + set use_table 0 + if {$has_textblock && $returntype in {table tableobject}} { + set use_table 1 + } + set errlines [list] ;#for non-textblock output + if {[catch { + if {$use_table} { + append errmsg \n + } else { + if {($returntype in {table tableobject}) && !$has_textblock} { + append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n + } else { + append errmsg \n + } + } + set cmdname [Dict_getdef $spec_dict cmd_info -name ""] + set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] + + set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] + set docurl [Dict_getdef $spec_dict doc_info -url ""] + + #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] + #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] + #if {"$argdisplay_header$argdisplay_body" eq ""} { + # set is_custom_argdisplay 0 + #} else { + # set is_custom_argdisplay 1 + #} + + #temp - TODO + set argdisplay_header "" + set argdisplay_body "" + set is_custom_argdisplay 0 + + + set blank_header_col [list] + if {$cmdname ne ""} { + lappend blank_header_col "" + set cmdname_display $CLR(cmdname)$cmdname$RST + } else { + set cmdname_display "" + } + if {$cmdhelp ne ""} { + lappend blank_header_col "" + #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] + set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] + } else { + set cmdhelp_display "" + } + if {$docurl ne ""} { + lappend blank_header_col "" + set docurl_display [a+ white]$docurl$RST + } else { + set docurl_display "" + } + #synopsis + set synopsis "" + set form_info [dict get $spec_dict form_info] + dict for {fid finfo} $form_info { + set form_synopsis [Dict_getdef $finfo -synopsis ""] + if {$form_synopsis eq ""} { + #todo + set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] + if {[string length $form_synopsis] > 90} { + set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] + } + if {[string match (autodef)* $form_synopsis]} { + set form_synopsis [string range $form_synopsis 9 end] + } + } + if {$fid in $selected_forms} { + set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] + } + append synopsis $form_synopsis \n + } + if {$synopsis ne ""} { + set synopsis [string trimright $synopsis \n] + lappend blank_header_col "" + } + + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + if {$use_table} { + set t [textblock::class::table new "$CLR(title)Usage$RST"] + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col + + if {!$is_custom_argdisplay} { + lappend blank_header_col "" + #spanned columns in default argdisplay area + $t add_column -headers $blank_header_col ;#Default + $t add_column -headers $blank_header_col ;#Multi + $t add_column -headers $blank_header_col ;#Help + set arg_colspans {1 4 0 0 0} + } else { + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } + set arg_colspans {1 1} + } + } + set h 0 + if {$cmdname ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] + } else { + lappend errlines "COMMAND: $cmdname_display" + } + incr h + } + if {$cmdhelp ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] + } else { + lappend errlines "Description: $cmdhelp_display" + } + incr h + } + if {$docurl ne ""} { + if {![catch {package require punk::ansi}]} { + set docurl [punk::ansi::hyperlink $docurl] + } + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] + } else { + lappend errlines "$docname $docurl_display" + } + incr h + } + if {$synopsis ne ""} { + if {$use_table} { + $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] + } else { + #todo + lappend errlines "Synopsis:\n$synopsis" + } + incr h + } + + + if {$use_table} { + if {$is_custom_argdisplay} { + if {$argdisplay_header ne ""} { + $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] + } + } else { + $t configure_header $h -values {Arg Type Default Multi Help} + } + } else { + lappend errlines " --ARGUMENTS-- " + } + + if {$is_custom_argdisplay} { + if {$use_table} { + #using overall container table + #header already added + #TODO - review textblock::table features + #we can't currently span columns within the table body. + #This feature could allow hidden data columns (and sort on hidden col?) + #potentially require coordination with header colspans? + $t add_row [list "" $argdisplay_body] + } else { + if {$argdisplay_header ne ""} { + lappend errlines $argdisplay_header + } + lappend errlines {*}$argdisplay_body + } + } else { + + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG $CLR(badarg) + set A_GOODARG $CLR(goodarg) + set A_GOODCHOICE $CLR(goodchoice) + set greencheck $CLR(check)\u2713$RST ;#green tick + set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { + #A_PREFIX can resolve to empty string if colour off + #we then want to display underline instead + set A_PREFIX [a+ underline] + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + } else { + set A_PREFIXEND $RST + } + + #TODO - foreach fid + set fid [lindex $selected_forms 0] + set form_dict [dict get $spec_dict FORMS $fid] + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $form_dict OPT_NAMES]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $form_dict OPT_NAMES] { + set arginfo [dict get $form_dict ARG_INFO $c] + if {[dict get $arginfo -prefix]} { + 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 + } else { + lappend opt_names_display $c + } + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } + } else { + set opt_names [dict get $form_dict OPT_NAMES] + set opt_names_display $opt_names + } + } + set leading_val_names [dict get $form_dict LEADER_NAMES] + set trailing_val_names [dict get $form_dict VAL_NAMES] + + #dict for {argname info} [tcl::dict::get $form_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + #puts "--> parsedargs: $parsedargs" + set parsed_leaders [Dict_getdef $parsedargs leaders {}] + set parsed_opts [Dict_getdef $parsedargs opts {}] + set parsed_values [Dict_getdef $parsedargs values {}] + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { + lassign $argumentset argnames_display argnames parsedvalues + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $form_dict ARG_INFO $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } else { + set default "" + } + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicemultiple [dict get $arginfo -choicemultiple] + if {[string is integer -strict $choicemultiple]} { + set choicemultiple [list $choicemultiple $choicemultiple] + } + lassign $choicemultiple choicemultiple_min choicemultiple_max + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + set is_multiple 1 + } else { + set multiple "" + set is_multiple 0 + } + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + if {$choicemultiple_max == -1} { + append help \n " The value can be a list of $choicemultiple_min or more of these choices" + } else { + if {$choicemultiple_min eq $choicemultiple_max} { + append help \n " The value must be a list of $choicemultiple_min of these choices" + } else { + append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" + } + } + } + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set mk " [join $markers {}]" + } else { + set mk "" + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + #puts "-- parsed:$parsedvalues arg:$arg c:$c" + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c [join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } else { + #set formattedchoices $choicegroups + dict for {groupname clist} $choicegroups { + foreach c $clist { + set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] + if {[llength $markers]} { + set cdisplay "$c[join $markers {}]" + } else { + set cdisplay $c + } + if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { + dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] + } else { + dict lappend formattedchoices $groupname $cdisplay + } + } + } + } + + } + } + set choicetable_objects [list] + set choicetable_footers [dict create] + dict for {groupname formatted} $formattedchoices { + set numcols $choicecolumns ;#todo - dynamic? + if {[llength $formatted] < $numcols} { + #don't show blank cells if single line of results + set numcols [llength $formatted] + } + if {$numcols > 0} { + if {$use_table} { + #risk of recursing + #TODO -title directly in list_as_table + set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] + lappend choicetable_objects $choicetableobj + $choicetableobj configure -title $CLR(groupname)$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + append help \n \n "$CLR(groupname)Group: $groupname$RST" + } else { + append help \n + } + append help \n [join $formatted \n] + } + } else { + #we were given an empty set of choices. + #probably an error in the definition - but could happen if dynamically generated. + #(e.g ensemble where unknown mechanism is used for subcommands?) + #better to just display that there were none rather than totally break the usage output. + if {$usetable} { + #these will be displayed after all table entries + if {$groupname eq ""} { + dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" + } else { + dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" + } + } else { + if {$groupname eq ""} { + append help \n " " $CLR(errormsg)(no choices defined)$RST + } else { + append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST + } + } + } + } + set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width + foreach obj $choicetable_objects { + dict lappend twidths_by_colcount [$obj column_count] [$obj width] + } + foreach obj $choicetable_objects { + set cols [$obj column_count] + set widths [dict get $twidths_by_colcount $cols] + set max [tcl::mathfunc::max {*}$widths] + $obj configure -minwidth $max ;#expand smaller ones + set i 0 + while {$i < $cols} { + #keep text aligned left on expanded tables + $obj configure_column $i -blockalign left + incr i + } + + append help \n[textblock::join -- " " [$obj print]] + #set ansititle [dict get [$obj configure -title] value] + $obj destroy + } + if {[dict size $choicetable_footers]} { + foreach groupname [dict keys $formattedchoices] { + if {[dict exists $choicetable_footers $groupname]} { + append help \n [dict get $choicetable_footers $groupname] + } + } + } + + #review. use -type to restrict additional choices - may be different to values in the -choices + if {![dict get $arginfo -choicerestricted]} { + #when -choicemultiple - the -type refers to each selection + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" + } else { + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" + } + } + } + if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + if {$is_multiple} { + set argshow "?${argshow}...?" + } else { + set argshow "?${argshow}?" + } + } else { + if {$is_multiple} { + set argshow "${argshow}..." + } + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + if {[dict exists $arginfo -minsize]} { + append typeshow \n "-minsize [dict get $arginfo -minsize]" + } + if {[dict exists $arginfo -maxsize]} { + append typeshow \n "-maxsize [dict get $arginfo -maxsize]" + } + if {[dict exists $arginfo -range]} { + append typeshow \n "-range [dict get $arginfo -range]" + } + + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } elseif {$arg in $goodargs} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + if {$arg eq $badarg} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] + } elseif {$arg in $goodargs} { + set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] + } + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp + } + } + } + } ;#end is_custom_argdisplay + + if {$use_table} { + $t configure -show_hseps 0\ + -show_header 1\ + -ansibase_body $CLR(ansibase_body)\ + -ansibase_header $CLR(ansibase_header)\ + -ansiborder_header $CLR(ansiborder)\ + -ansiborder_body $CLR(ansiborder) + + $t configure -maxwidth 80 ;#review + if {$returntype ne "tableobject"} { + append errmsg [$t print] + #returntype of table means just the text of the table + $t destroy + } + } else { + append errmsg [join $errlines \n] + } + } errM]} { + catch {$t destroy} + append errmsg \n + append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n + append errmsg "$errM" \n + append errmsg "$::errorInfo" + + } + set arg_error_isrunning 0 + if {$use_table} { + #assert returntype is one of table, tableobject + set result $errmsg ;#default if for some reason table couldn't be used + if {$returntype eq "tableobject"} { + if {[info object isa object $t]} { + set result $t + } + } + } else { + set result $errmsg + } + if {$as_error} { + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] + } else { + return $result + } + } + + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command identified by an id. + + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. The id for custom + help for a command should match the fully qualified name of the command. + + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and may not yet have an id. + IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. + + Generally punk::ns::arginfo (aliased as i in the punk shell) should + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. + " + -return -default table -choices {string table tableobject} + }\ + {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ + {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ + { + + @values -min 0 -max 1 + id -help\ + "Exact id. + Will usually match the command name" + }] + proc usage {args} { + #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received + lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received + set id [dict get $values id] + set real_id [real_id $id] + if {$real_id eq ""} { + error "punk::args::usage - no such id: $id" + } + #-scheme punk_info ?? + arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 + } + + lappend PUNKARGS [list { + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 + id + arglist -type list -help\ + "list containing arguments to be parsed as per the + argument specification identified by the supplied id." + }] + + + #deprecate? + proc get_by_id {id arglist} { + set definitionlist [punk::args::raw_def $id] + if {[llength $definitionlist] == 0} { + error "punk::args::get_by_id - no such id: $id" + } + #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] + tailcall ::punk::args::get_dict $definitionlist $arglist + } + + #consider + + #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) + #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withdef $def ?$def?... + + #an experiment.. ideally we'd like arglist at the end? + #parse_withid ?-flag val?.. $id $arglist + #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? + #no possible equivalent for parse_withdef ??? + + lappend PUNKARGS [list { + @id -id ::punk::args::parse + @cmd -name punk::args::parse -help\ + "parse and validate command arguments based on a definition. + + In the 'withid' form the definition is a pre-existing record that has been + created with ::punk::args::define, or indirectly by adding a definition to + the PUNKARGS variable in a namespace which is then registered in + punk::args::register::NAMESPACES, or by a previous call to punk::parse + using 'withdef' and a definition block containing an @id -id directive. + + In the 'withdef' form - the definition is created on the first call and + cached thereafter, if the id didn't already exist. + + form1: parse $arglist ?-flag val?... withid $id + form2: parse $arglist ?-flag val?... withdef $def ?$def? + see punk::args::define + + Returns a dict of information regarding the parsed arguments + example of basic usage for single option only: + punk::args::define { + @id -id ::myns::myfunc + @cmd -name myns::myfunc + @leaders -min 0 -max 0 + @opts + -configfile -type existingfile + #type none makes it a solo flag + -verbose -type none + @values -min 0 -max 0 + } + proc myfunc {args} { + set argd [punk::args::parse $args withid ::myns::myfunc] + lassign [dict values $argd] leaders opts values received solos + if {[dict exists $received] -configfile} { + puts \"have option for existing file [dict get $opts -configfile]\" + } + } + The leaders, opts, values keys in the parse result dict are proper dicts. + The received key is dict-like but can have repeated keys for arguments than can + accept multiples. The value for each received element is the ordinal position. + The solos key refers to a list of solo flags received (those specified with + -type none). This is generally only useful to assist in passing arguments on + to another procedure which also requires solos, because the opts dict contains + solo flags with a 1 value or a list of 1's if it was a solo with -multiple true + specified. + " + @form -form {withid withdef} + @leaders -min 1 -max 1 + arglist -type list -optional 0 -help\ + "Arguments to parse - supplied as a single list" + + @opts + -form -type list -default * -help\ + "Restrict parsing to the set of forms listed. + Forms are the orthogonal sets of arguments a + command can take - usually described in 'synopsis' + entries." + #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance + #todo - configurable per interp/namespace + -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} + + @values -min 2 + + @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" + @values -max 2 + withid -type literal -help\ + "The literal value 'withid'" + id -type string -help\ + "id of punk::args definition for a command" + + + @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" + withdef -type literal -help\ + "The literal value 'withdef'" + + #todo - make -dynamic obsolete - use @dynamic directive instead + def -type string -multiple 1 -optional 0 -help\ + "Each remaining argument is a block of text + defining argument definitions. + As a special case, -dynamic may be + specified as the 1st 2 arguments. These are + treated as an indicator to punk::args about + how to process the definition." + + }] + proc parse {args} { + set tailtype "" ;#withid|withdef + if {[llength $args] < 3} { + #error "punk::args::parse - invalid call. < 3 args" + punk::args::parse $args withid ::punk::args::parse + } + set opts_and_vals $args + set parseargs [lpop opts_and_vals 0] + + set opts [list] + set values [list] + for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { + if {[string match -* [lindex $opts_and_vals $i]]} { + if {[catch { + lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] + }]} { + #unhappy path - not enough options + #review - which form of punk::args::parse? + punk::args::parse $args withid ::punk::args::parse + } + incr i -1 + #lappend opts $a [lindex $opts_and_vals $i] + } else { + break + } + } + #set values [lrange $opts_and_vals $i end] + set values $opts_and_vals + #puts "---values: $values" + set tailtype [lindex $values 0] + set tailargs [lrange $values 1 end] + + + #set split [lsearch -exact $tailargs withid] + #if {$split < 0} { + # set split [lsearch -exact $tailargs withdef] + # if {$split < 0} { + # #punk::args::usage arg_error? + # #error "punk::args::parse - invalid call. keyword withid|withdef required" + # punk::args::parse $args withid ::punk::args::parse + # } else { + # set tailtype withdef + #} + #} else { + # set tailtype withid + #} + #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. + + + #if {[llength $opts] % 2} { + #error "punk::args::parse Even number of -flag val pairs required after arglist" + #} + + #Default the -errorstyle to enhanced + # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) + # - application devs should distribute a config file with an errorstyle override if desired. + # - devs who prefer a different default for interactive use should create a config for it. (todo) + set defaultopts [dict create\ + -form {*}\ + -errorstyle enhanced\ + ] + + #todo - load override_errorstyle from configuration + #dict set defaultopts -errorstyle $ + #puts "def: $defaultopts opts: $opts" + set opts [dict merge $defaultopts $opts] + dict for {k v} $opts { + switch -- $k { + -form - -errorstyle { + } + default { + #punk::args::usage $args withid ::punk::args::parse ?? + #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + punk::args::parse $args withid ::punk::args::parse + } + } + } + switch -- $tailtype { + withid { + if {[llength $tailargs] != 1} { + #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + punk::args::parse $args withid ::punk::args::parse + } + set id [lindex $tailargs 0] + #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" + set deflist [raw_def $id] + if {[llength $deflist] == 0} { + error "punk::args::parse - no such id: $id" + } + } + withdef { + set deflist $tailargs + if {[llength $deflist] < 1} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" + } + default { + error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" + } + } + try { + set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] + } trap {PUNKARGS VALIDATION} {msg erroropts} { + set opt_errorstyle [dict get $opts -errorstyle] + + #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg + #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + + + set ecode [dict get $erroropts -errorcode] + #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... + set msg [string map [list %caller% [Get_caller]] $msg] + switch -- $opt_errorstyle { + minimal { + return -options [list -code error -errorcode $ecode] $msg + } + basic { + #No table layout - unix manpage style + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + standard { + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + } + return -options [list -code error -errorcode $ecode] $msg + } + enhanced { + set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) + set customdict [lrange $ecode 3 end] + set argspecs [Dict_getdef $customdict -argspecs ""] + set badarg [Dict_getdef $customdict -badarg ""] + set ecode_summary [lrange $ecode 0 2] + if {$badarg ne ""} { + lappend ecode_summary -badarg $badarg + } + catch {package require punk::lib} + if {[package provide punk::lib] ne ""} { + append msg \n [punk::lib::showdict -roottype list $estack */*] + } + if {$argspecs ne ""} { + set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } else { + #why? todo? + append msg \n "(enhanced error information unavailable)" + append msg \n "::errorCode summary: $ecode_summary" + return -options [list -code error -errorcode $ecode] $msg + } + } + debug { + puts stderr "errorstyle debug not implemented" + return -options [list -code error -errorcode $ecode] $msg + } + default { + puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" + return -options [list -code error -errorcode $ecode] $msg + } + } + } trap {PUNKARGS} {msg erropts} { + append msg \n "Unexpected PUNKARGS error" + return -options [list -code error -errorcode $ecode] $msg + } trap {} {msg erroropts} { + #review + #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. + #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. + throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] + } + return $result + } + proc parseXXX {args} { + #no solo flags allowed for parse function itself. (ok for arglist being parsed) + set opts [dict create] ;#repeated flags will override earlier. That's ok here. + set arglist {} + set got_arglist 0 + set tailtype "" ;#withid|withdef + set id "" + for {set i 0} {$i < [llength $args]} {incr i} { + set a [lindex $args $i] + if {[string match -* $a]} { + dict set opts $a [lindex $args $i+1] + incr i + } else { + set arglist $a + set got_arglist 1 + set tailtype [lindex $args $i+1] + if {$tailtype eq "withid"} { + if {[llength $args] != $i+3} { + error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" + } + set id [lindex $args $i+2] + break + } elseif {$tailtype eq "withdef"} { + if {[llength $args] < $i+3} { + error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" + } + set deflist [lrange $args $i+2 end] + break + } else { + error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" + } + } + } + if {!$got_arglist} { + error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." + } + #assert tailtype eq withid|withdef + if {$tailtype eq "withid"} { + #assert $id was provided + return "parse [llength $arglist] args withid $id, options:$opts" + } else { + #assert llength deflist >=1 + return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" + } + #TODO + } + + #todo? - a version of get_dict that directly supports punk::lib::tstr templating + #rename get_dict + # + + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + proc get_dict {deflist rawargs args} { + #see arg_error regarding considerations around unhappy-path performance + + if {[llength $args] % 2 != 0} { + error "punk::args::get_dict args must be a dict of option value pairs" + } + set defaults [dict create\ + -form *\ + ] + set opts [dict merge $defaults $args] + dict for {k v} $opts { + switch -- $k { + -form {} + default { + error "punk::args::get_dict Unexpected option '$k' Known options -form" + } + } + } + + + #*** !doctools + #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] + #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values + #[para]Returns a dict of the form: opts values + #[para]ARGUMENTS: + #[list_begin arguments] + #[arg_def list-of-multiline-string deflist] + #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced + #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values + #[para]Each optionspec line defining a flag must be of the form: + #[para]-optionname -key val -key2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]Each optionspec line defining a positional argument is of the form: + #[para]argumentname -key val -ky2 val2... + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. + #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. + #[arg_def list rawargs] + #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, + #but it could be a manually constructed list of values made for example from positional args defined in the proc. + #[list_end] + #[para] + + #consider line-processing example below for which we need info complete to determine record boundaries + #punk::args::get_dict [list { + # @opts + # -opt1 -default {} + # -opt2 -default { + # etc + # } + # @values -multiple 1 + #}] $args + + + + + #rawargs: args values to be parsed + #we take a definition list rather than resolved argspecs - because the definition could be dynamic + + #if definition has been seen before, + #define will either return a permanently cached argspecs (-dynamic 0) - or + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] + + # ----------------------------------------------- + # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) + tcl::dict::with argspecs {} ;#turn keys into vars + #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names + # ----------------------------------------------- + set opt_form [dict get $opts -form] + if {$opt_form eq "*"} { + set selected_forms $form_names + } elseif {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list [lindex $form_names $opt_form]] + } else { + if {$opt_form ni $form_names} { + error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set selected_forms [list $opt_form] + } + + + #puts "-arg_info->$arg_info" + set flagsreceived [list] ;#for checking if required flags satisfied + set solosreceived [list] + set multisreceived [list] + #secondary purpose: + #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. + #-default value must not be appended to if argname not yet in flagsreceived + + + #todo: -minmultiple -maxmultiple ? + + # -- --- --- --- + # Handle leading positionals + # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? + + #todo - handle multiple fids? + set fid [lindex $selected_forms 0] + set formdict [dict get $FORMS $fid] + tcl::dict::with formdict {} + #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc + if {$VAL_MIN eq ""} { + set valmin 0 + set VAL_MIN 0 + } else { + set valmin $VAL_MIN + } + + 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-1} { + if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { + break + } else { + if {$VAL_MIN ne ""} { + if {[llength $rawargs] > $VAL_MIN} { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } else { + break + } + } else { + lappend pre_values [lpop rawargs 0] + dict incr leader_posn_names_assigned $leader_posn_name + } + } + } 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 + + #JJJJ + if {$LEADER_MIN eq ""} { + set leadermin 0 + } else { + set leadermin $LEADER_MIN + } + if {$LEADER_MAX eq ""} { + set leadermax -1 + } else { + set leadermax $LEADER_MAX + } + + if {$VAL_MAX eq ""} { + set valmax -1 + } else { + set valmax $VAL_MAX + } + + #assert leadermax leadermin are numeric + #assert - rawargs has been reduced by leading positionals + + set opts [dict create] ;#don't set to OPT_DEFAULTS here + + + set leaders [list] + set arglist {} + set post_values {} + #valmin, valmax + #puts stderr "rawargs: $rawargs" + #puts stderr "argstate: $argstate" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$valmax == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $valmax + set vals_remaining_possible $vals_total_possible + } + for {set i 0} {$i <= $maxidx} {incr i} { + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest valmin is 0 + if {$remaining_args_including_this <= $valmin} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $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 <= valmin already covered above + if {$valmax != -1} { + #finite max number of vals + if {$remaining_args_including_this == $valmax} { + #assume it's a value. + set arglist [lrange $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 -prefix] && $a ne $fullopt} { + #attempt to use a prefix when not allowed + #review - by ending opts here - we dont' get the clearest error msgs + # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error + # (but it may actually be the first value that just happens to be flaglike) + #todo - check for subsequent valid flags or -- marker? + #consider for example 'file delete -f -- old.txt' + #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values + #whereas the builtin file arg parser alerts that -f is a bad option + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #set arglist [lrange $rawargs 0 $i-1] + #set post_values [lrange $rawargs $i end] + #break + } + if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 + } + } 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 + } + if {$fullopt ni $multisreceived} { + lappend multisreceived $fullopt + } + } 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 valmin already done above + if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding valmax valmin + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $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 + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a $newval + } + if {[incr i] > $maxidx} { + set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg + #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $argstate $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + if {$a ni $multisreceived} { + lappend multisreceived $a + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + lappend solosreceived $a + } + lappend flagsreceived $a ;#adhoc flag as supplied + } else { + if {[llength $OPT_NAMES]} { + set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" + } else { + set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg + #arg_error $errmsg $argspecs -badarg $fullopt + } + } + } + } else { + #not flaglike + set arglist [lrange $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 ordered_opts [dict create] + foreach o $OPT_NAMES { + if {[dict exists $opts $o]} { + dict set ordered_opts $o [dict get $opts $o] + } elseif {[dict exists $OPT_DEFAULTS $o]} { + dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] + } + } + #add in possible '-any true' opts after the defined opts + dict for {o oval} $opts { + if {![dict exists $ordered_opts $o]} { + dict set ordered_opts $o $oval + } + } + set opts $ordered_opts + #--------------------------------------- + + + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set in_multiple "" + set leadernames_received [list] + + set num_leaders [llength $leaders] + #---------------------------------------- + #set leaders_dict $LEADER_DEFAULTS ;#wrong + set leaders_dict [dict create] + foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { + dict set leaders_dict $lname {} + } + set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] + #---------------------------------------- + + 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 valname_multiple "" + set valnames_received [list] + + set num_values [llength $values] + #------------------------------------------ + #!!! review + ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults + ## set values_dict $val_defaults + set values_dict [dict create] + foreach valname [lrange $VAL_NAMES 0 $num_values-1] { + dict set values_dict $valname {} + } + set values_dict [dict merge $values_dict $VAL_DEFAULTS] + #------------------------------------------ + set nameidx 0 + set start_position $positionalidx + for {set validx 0} {$validx < [llength $values]} {incr validx} { + set valname [lindex $VAL_NAMES $nameidx] + incr nameidx + set val [lindex $values $validx] + if {$valname ne ""} { + if {[llength $valname] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + + if {[tcl::dict::get $argstate $valname -multiple]} { + if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list + } else { + tcl::dict::lappend values_dict $valname $strideval + } + set valname_multiple $valname + } else { + tcl::dict::set values_dict $valname $strideval + } + lappend valnames_received $valname + } else { + if {$valname_multiple ne ""} { + if {[llength $valname_multiple] == 1} { + set strideval $val + } else { + set strideval [list] + incr validx -1 + foreach v $valname_multiple { + incr validx + if {$validx > [llength $values]-1} { + set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg + } + lappend strideval [lindex $values $validx] + } + } + tcl::dict::lappend values_dict $valname_multiple $strideval + #name already seen - but must add to valnames_received anyway (as with opts and leaders) + lappend valnames_received $valname_multiple + } else { + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS + tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS + lappend valnames_received $positionalidx + } + } + set positionalidx [expr {$start_position + $validx}] + } + #------------------------------------------ + + if {$leadermax == -1} { + #only check min + if {$num_leaders < $leadermin} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } else { + if {$num_leaders < $leadermin || $num_leaders > $leadermax} { + if {$leadermin == $leadermax} { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg + } + } + } + + if {$valmax == -1} { + #only check min + if {$num_values < $valmin} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } else { + if {$num_values < $valmin || $num_values > $valmax} { + if {$valmin == $valmax} { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } else { + set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg + } + } + } + + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + + + #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) + #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call + #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW + #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true + + #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? + #example timing difference: + #struct::set difference {x} {a b} + #normal interp 0.18 u2 vs safe interp 9.4us + #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + #} + #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + #} + #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { + set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg + #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } + 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 + } + + switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { + leader { + set dname leaders_dict + set argclass "Leading argument" + } + option { + set dname opts + set argclass Option + } + value { + set dname values_dict + set argclass "Trailing argument" + } + default { + set dname "_unknown_" ;#NA + set argclass "Unknown argument" + } + } + #reduce our validation requirements by removing values which match defaultval or match -choices + #(could be -multiple with -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 + + + set idx 0 ;# + #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes + #assert llength $vlist == llength [dict get $dname $argname] + # (unless there was a default and the option wasn't specified) + set vlist_validate [list] + set vlist_check_validate [list] + foreach e $vlist e_check $vlist_check { + set allchoices_in_list 0 + if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { + #vlist and vlist_check can be list of lists if -multiple and -choicemultiple + #each e represents 0 or more choice selections + set c_list $e + set c_check_list $e_check + #todo? check if entire list matches default? + } else { + #only one choice at a time - ensure single entry in c_list c_check_list + set c_list [list $e] + set c_check_list [list $e_check] + } + + + #----------------------------------- + #fast fail on the wrong number of choices + if {[llength $c_list] < $choicemultiple_min} { + set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { + set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg + } + #----------------------------------- + + set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list + foreach c $c_list c_check $c_check_list { + if {$nocase} { + set casemsg " (case insensitive)" + set choices_test [tcl::string::tolower $allchoices] + #Don't lcase the denylist - even in nocase mode! + #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] + set v_test [tcl::string::tolower $c_check] + } else { + set casemsg " (case sensitive)" + set v_test $c_check + set choices_test $allchoices + } + set choice_in_list 0 + set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? + if {!$matches_default} { + if {$choiceprefix} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$c_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $c_check + set choice_in_list 1 + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + #assert - if we're here, nocase must be true + #we know choice is present as full-length match except for case + #now we want to select the case from the choice list - not the supplied value + #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #review + foreach avail [lsort -unique $allchoices] { + if {[string match -nocase $c $avail]} { + set chosen $avail + } + } + #assert chosen will always get set + set choice_in_list 1 + } else { + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. + #in this block we can treat empty result from prefix match as a non-match + if {$nocase} { + #nocase implies that our entered value doesn't have to match case of choices - + #but we would still like to select the best match if there are case-dups. + #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete + # selecting Del will find Delete, del will match delete (and raise error) + # but DEL will also match delete rather than Delete - so again an error is raised. + #This is counterintuitive with -nocase + #This is probably such an edge case that best served with documentation as a feature-not-bug + #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? + #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. + + set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing + set chosen [lsearch -inline -nocase $allchoices $chosen] + set choice_in_list [expr {$chosen ne ""}] + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] + if {$chosen eq ""} { + set choice_in_list 0 + } else { + set choice_in_list 1 + } + } + #override choice_in_list if in deny list + #don't allow prefixing for elements from -choiceprefixdenylist + #we still use all elements to calculate the prefixes though + #review - case difference edge cases in choiceprefixdenylist !todo + if {$chosen in $choiceprefixdenylist} { + set choice_in_list 0 + set chosen "" + } + } + + #override the optimistic existing val + if {$choice_in_list && !$choice_exact_match} { + if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { + if {$is_multiple} { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $idx $chosen + tcl::dict::set $dname $argname $existing + } else { + tcl::dict::set $dname $argname $chosen + } + } else { + if {$is_multiple} { + set existing_all [tcl::dict::get [set $dname] $argname] + lset existing_all $idx $choice_idx $chosen + tcl::dict::set $dname $argname $existing_all + } else { + set existing [tcl::dict::get [set $dname] $argname] + lset existing $choice_idx $chosen + tcl::dict::set $dname $argname $existing + } + } + } + } else { + #value as stored in $dname is ok + set choice_in_list [expr {$v_test in $choices_test}] + } + } + + if {!$choice_in_list && !$matches_default} { + if {!$choicerestricted} { + #if {$is_multiple} { + # set existing [tcl::dict::get [set $dname] $argname] + # lset existing $idx $v_test + # tcl::dict::set $dname $argname $existing + #} else { + # tcl::dict::set $dname $argname $v_test + #} + lappend vlist_validate $c + lappend vlist_check_validate $c_check + } else { + #unhappy path + if {$choiceprefix} { + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + } + #review: $c vs $c_check for -badval? + set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname + } + } + incr choice_idx + } + + incr idx + } + #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation + #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + if {[llength $vlist] && $has_default} { + set vlist_validate [list] + set vlist_check_validate [list] + foreach c $vlist c_check $vlist_check { + #for -choicemultiple with default that could be a list use 'ni' ?? review + if {$c_check ne $defaultval} { + lappend vlist_validate $c + lappend vlist_check_validate $c + } + } + set vlist $vlist_validate + set vlist_check $vlist_check_validate + } + + #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups + #assert: our vlist & vlist_check lists have been reduced to remove those + if {[llength $vlist] && !$is_allow_ansi} { + #allow_ansi 0 + package require punk::ansi + #do not run ta::detect on a list + foreach e $vlist { + if {[punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + #puts "argname:$argname v:$v is_default:$is_default" + #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value + #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. + #arguments that are at their default are not subject to type and other checks + + #don't validate defaults or choices that matched + #puts "---> opts_and_values: $opts_and_values" + #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" + #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} + + #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups + #assert [llength $vlist] == [llength $vlist_check] + if {[llength $vlist]} { + switch -- $type { + literal { + foreach e $vlist { + if {$e ne $argname} { + set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + indexexpression { + foreach e_check $vlist_check { + if {[catch {lindex {} $e_check}]} { + set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + string - ansistring - globstring { + #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string + #we possibly don't want to always have to regex on things that don't pass the other more basic checks + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) + # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) + # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail + + #todo? - way to validate both unstripped and stripped? + set pass_quick_list_e [list] + set pass_quick_list_e_check [list] + set remaining_e $vlist + set remaining_e_check $vlist_check + #review - order of -regexprepass and -regexprefail in original rawargs significant? + #for now -regexprepass always takes precedence + if {$regexprepass ne ""} { + foreach e $vlist e_check $vlist_check { + if {[regexp $regexprepass $e]} { + lappend pass_quick_list_e $e + lappend pass_quick_list_e_check $e_check + } + } + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] + } + if {$regexprefail ne ""} { + foreach e $remaining_e e_check $remaining_e_check { + #puts "----> checking $e vs regex $regexprefail" + if {[regexp $regexprefail $e]} { + if {[tcl::dict::exists $thisarg -regexprefailmsg]} { + #review - %caller% ?? + set msg [tcl::dict::get $thisarg -regexprefailmsg] + } else { + set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" + } + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + switch -- $type { + ansistring { + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #.. so we need to look at the original values in $vlist not $vlist_check + + #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? + #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? + package require punk::ansi + foreach e $remaining_e { + if {![punk::ansi::ta::detect $e]} { + set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + globstring { + foreach e $remaining_e { + if {![regexp {[*?\[\]]} $e]} { + set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg + } + } + } + } + + if {[tcl::dict::size $thisarg_checks]} { + foreach e_check $remaining_e_check { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::string::length $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::string::length $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + number { + #review - consider effects of Nan and Inf + #NaN can be considered as 'technically' a number (or at least a special numeric value) + lassign {} low high ;#set both empty + set has_range 0 + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + set has_range 1 + } + } + foreach e $vlist e_check $vlist_check { + if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$has_range} { + if {[::tcl::mathfunc::isnan $e]} { + set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {$low eq ""} { + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } elseif {$high eq ""} { + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } else { + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + int { + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + if {[tcl::dict::exists $thisarg -range]} { + lassign [tcl::dict::get $thisarg -range] low high + if {"$low$high" ne ""} { + if {$low eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #lowside unspecified - check only high + if {$e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } elseif {$high eq ""} { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #highside unspecified - check only low + if {$e_check < $low} { + set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } else { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + #high and low specified + if {$e_check < $low || $e_check > $high} { + set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } else { + foreach e_check $vlist_check { + if {![tcl::string::is integer -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + double { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is double -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type double. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + #safe jumptable test + #dict for {checkopt checkval} $thisarg_checks {} + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -range { + #todo - small-value double comparisons with error-margin? review + #todo - empty string for low or high + lassign $checkval low high + if {$e_check < $low || $e_check > $high} { + set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + bool { + foreach e_check $vlist_check { + if {![tcl::string::is boolean -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + dict { + foreach e_check $vlist_check { + if {[llength $e_check] %2 != 0} { + set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minsize { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + -maxsize { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg + } + } + } + } + } + } + } + } + alnum - + alpha - + ascii - + control - + digit - + graph - + lower - + print - + punct - + space - + upper - + wordchar - + xdigit { + foreach e $vlist e_check $vlist_check { + if {![tcl::string::is $type -strict $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + } + file - + directory - + existingfile - + existingdirectory { + foreach e $vlist e_check $vlist_check { + #//review - we may need '?' char on windows + if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { + #what about special file names e.g on windows NUL ? + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg + } + } + if {$type eq "existingfile"} { + foreach e $vlist e_check $vlist_check { + if {![file exists $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } elseif {$type eq "existingdirectory"} { + foreach e $vlist e_check $vlist_check { + if {![file isdirectory $e_check]} { + set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + char { + #review - char vs unicode codepoint vs grapheme? + foreach e $vlist e_check $vlist_check { + if {[tcl::string::length $e_check] != 1} { + set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg + } + } + } + } + + } + + if {$is_strip_ansi} { + set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach + if {[tcl::dict::get $thisarg -multiple]} { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } + } + } else { + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } + } + } + } + } + + #maintain order of opts $opts values $values as caller may use lassign. + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + if {[llength $receivednames]} { + #flat zip of names with overall posn, including opts + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + set i -1 + set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] + } else { + set received_posns [list] + } + #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) + #(e.g using 'dict exists $received -flag') + # - but it can have duplicate keys when args/opts have -multiple 1 + #It is actually a list of paired elements + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] + } + + + proc forms {id} { + set spec [get_spec $id] + if {[dict size $spec]} { + return [dict get $spec form_names] + } else { + return [list] + } + } + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis + @cmd -name punk::args::synopsis -help\ + "Return synopsis for each form of a command id + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + }] + proc synopsis {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis] + + if {[catch {package require punk::ansi} errM]} { + set has_punkansi 0 + } else { + set has_punkansi 1 + } + if {$has_punkansi} { + set I [punk::ansi::a+ italic] + set RST [punk::ansi::a] + } else { + set I "" + set RST "" + } + + ##set form * + ##if {[lindex $args 0] eq "-form"} { + ## set arglist [lrange $args 2 end] + ## set form [lindex $args 1] + ##} else { + ## set arglist $args + ##} + ##if {[llength $arglist] == 0} { + ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" + ##} + ##set id [lindex $arglist 0] + ##set cmdargs [lrange $arglist 1 end] + + lassign [dict values $argd] leaders opts values + set form [dict get $opts -form] + set opt_return [dict get $opts -return] + set cmditems [dict get $values cmditem] + set id [lindex $cmditems 0] + set cmdargs [lrange $cmditems 1 end] + + + set spec [get_spec $id] + if {$spec eq ""} { + return + } + set form_names [dict get $spec form_names] + if {$form ne "*"} { + if {[string is integer -strict $form]} { + set f [lindex $form_names $form] + if {$f ne ""} { + set form_names [list $f] + } else { + set form_names [list] + } + } else { + if {$form in $form_names} { + set form_names [list $form] + } else { + set form_names [list] + } + } + } + + set SYND [dict create] + set syn "" + #todo - -multiple etc + foreach f $form_names { + set SYNLIST [list] + dict set SYND $f [list] + append syn "$id" + set forminfo [dict get $spec FORMS $f] + foreach argname [dict get $forminfo LEADER_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class leader] + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display [lindex [dict get $arginfo -choices] 0] + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display $I$argname$RST + } + if {[dict get $arginfo -optional]} { + append syn " ?$display?" + } else { + append syn " $display" + } + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo OPT_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class option] + set tp [dict get $arginfo -type] + if {[dict get $arginfo -optional]} { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "?$argname?..." + } else { + set display "?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display "?$argname?" + } else { + set display "?$argname <$tp>?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + if {$tp eq "none"} { + set display "$argname ?$argname...?" + } else { + set display "$argname <$tp> ?$argname <$tp>?..." + } + } else { + if {$tp eq "none"} { + set display $argname + } else { + set display "$argname <$tp>" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + foreach argname [dict get $forminfo VAL_NAMES] { + set arginfo [dict get $forminfo ARG_INFO $argname] + set ARGD [dict create argname $argname class value] + if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { + if {[dict get $arginfo -multiple]} { + set display "?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "?[lindex [dict get $arginfo -choices] 0]?" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display "?$argname?" + } else { + set display "?$I$argname$RST?" + } + } + } else { + if {[dict get $arginfo -multiple]} { + set display "$I$argname$RST ?$I$argname$RST?..." + } else { + if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { + set display "[lindex [dict get $arginfo -choices] 0]" + } elseif {[dict get $arginfo -type] eq "literal"} { + set display $argname + } else { + set display "$I$argname$RST" + } + } + } + append syn " $display" + dict set ARGD type [dict get $arginfo -type] + dict set ARGD optional [dict get $arginfo -optional] + dict set ARGD display $display + dict lappend SYND $f $ARGD + } + append syn \n + } + switch -- $opt_return { + full { + return [string trim $syn \n] + } + summary { + set summary "" + dict for {form arglist} $SYND { + append summary $id + set class_state leader + set option_count 0 + set value_count 0 + foreach ainfo $arglist { + switch -- [dict get $ainfo class] { + leader { + append summary " [dict get $ainfo display]" + } + option { + incr option_count + } + value { + incr value_count + if {$class_state ne "value"} { + if {$option_count > 0} { + append summary " ?options ($option_count defined)?" + } + set class_state value + } + append summary " [dict get $ainfo display]" + } + } + } + if {$value_count == 0 && $option_count > 0} { + append summary " ?options ($option_count defined)?" + } + append summary \n + } + set summary [string trim $summary \n] + return $summary + } + dict { + return $SYND + } + } + } + + + lappend PUNKARGS [list { + @id -id ::punk::args::synopsis_summary + @cmd -name punk::args::synopsis_summary -help\ + "Reduce the width of a synopsis string + by coalescing options to ?options?... + synopsis string may be arbitrarily marked + up with ANSI codes." + @opts + @values -min 1 -max -1 + synopsis -multiple 0 -optional 0 + }] + proc synopsis_summary {args} { + set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set synopsis [dict get $argd values synopsis] + set summary "" + foreach sline [split $synopsis \n] { + set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review + set in_opt 0 + set line_out "" + set codestack [list] + set parts [punk::ansi::ta::split_codes_single $sline] + #basic + foreach {pt code} $parts { + set charlist [split $pt ""] + for {set i 0} {$i < [llength $charlist]} {incr i} { + set c [lindex $charlist $i] + + switch -- $c { + ? { + if {!$in_opt} { + set in_opt 1 + } else { + + } + } + " " { + if {!$in_opt} { + append line_out " " + } else { + set in_opt + } + } + default { + if {!$in_opt} { + append line_out $c + } + } + } + } + if {$code ne ""} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } else { + #? ignore other ANSI codes? + } + } + } + if {[string match -* $plain_s] || [string match ?- $plain_s]} { + } + } + return $summary + } + + lappend PUNKARGS [list { + @id -id ::punk::args::TEST + @opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + @opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + @values -min 0 -max 1 + v -help\ + "v1 optional" + }] + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::lib { + variable PUNKARGS + tcl::namespace::export * + tcl::namespace::path [list [tcl::namespace::parent]] + #*** !doctools + #[subsection {Namespace punk::args::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] + # #[para]Description of utility1 + # return 1 + #} + + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_based_posns {count} { + if {$count < 1} {return} + lseq 0 $count-1 + } + } else { + proc zero_based_posns {count} { + if {$count < 1} {return} + lsearch -all [lrepeat $count 0] * + } + } + + #return list of single column-width marks - possibly with ansi + proc choiceinfo_marks {choice choiceinfodict} { + set marks [list] + if {[dict exists $choiceinfodict $choice]} { + set cinfo [dict get $choiceinfodict $choice] + foreach info $cinfo { + if {[lindex $info 0] eq "doctype"} { + switch -- [lindex $info 1] { + punkargs { + lappend marks [punk::ns::Cmark punkargs brightgreen] + } + ensemble { + lappend marks [punk::ns::Cmark ensemble brightyellow] + } + oo { + lappend marks [punk::ns::Cmark oo brightcyan] + } + ooc { + lappend marks [punk::ns::Cmark ooc cyan] + } + ooo { + lappend marks [punk::ns::Cmark ooo cyan] + } + native { + lappend marks [punk::ns::Cmark native] + } + unknown { + lappend marks [punk::ns::Cmark unknown brightred] + } + } + } + } + } + return $marks + } + + + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} + lappend PUNKARGS [list { + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ + "A rough equivalent of js template literals + + Substitutions: + \$\{$varName\} + \$\{[myCommand]\} + (when -allowcommands flag is given)" + -allowcommands -default 0 -type none -help\ + "If -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + -undent -default 1 -type boolean -help\ + "undent/dedent the template lines. + The longest common prefix of whitespace is removed" + -indent -default "" -type string -help\ + "String with which to indent the template + prior to substitution. + If -undent is enabled, that is performed + first, then the indent is applied." + -paramindents -default line -choices {none line position} -choicelabels { + line\ + " Use leading whitespace in + the line in which the + placeholder occurs." + position\ + " Use the position in + the line in which the + placeholder occurs." + none\ + " No indents applied to + subsequent placeholder value + lines. This will usually + result in text awkwardly + ragged unless the source code + has also been aligned with the + left margin or the value has + been manually padded." + } -help\ + "How indenting is done for subsequent lines in a + multi-line placeholder substitution value. + The 1st line or a single line value is always + placed at the placeholder. + paramindents are performed after the main + template has been indented/undented. + (indenting by position does not calculate + unicode double-wide or grapheme cluster widths) + " + #choicelabels indented by 1 char is clearer for -return string - and reasonable in table + -return -default string -choices {dict list string args}\ + -choicelabels { + dict\ + " Return a dict with keys + 'template', 'params' and + 'errors'" + string\ + " Return a single result + being the string with + placeholders substituted." + list\ + " Return a 2 element list. + The first is itself a list + of plaintext portions of the + template, split at each point + at which placeholders were + present. The second element + of the outer list is a list + of placeholder values if -eval + is 1, or a list of the raw + placeholder strings if -eval + is 0." + args\ + " Return a list where the first + element is a list of template + plaintext sections as per the + 'list' return mechanism, but the + placeholder items are individual + items in the returned list. + This can be useful when passing + the expanded result of a tstr + command to another function + which expects the placeholders + as individual arguments" + } + -eval -default 1 -type boolean -help\ + "Whether to evaluate the \$\{\} placeholders. + When -return is string, -eval should generally be set to 1. + For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. + contained variables in that case should be braced or whitespace separated, or the variable + name is likely to collide with surrounding text. + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + @values -min 0 -max 1 + templatestring -help\ + "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true + e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} + + Escape sequences such as \\n and unicode escapes are processed within placeholders. + " + }] + + proc tstr {args} { + #Too hard to fully eat-our-own-dogfood from within punk::args package + # - we use punk::args within the unhappy path only + #set argd [punk::args::get_by_id ::punk::lib::tstr $args] + #set templatestring [dict get $argd values templatestring] + #set opt_allowcommands [dict get $argd opts -allowcommands] + #set opt_return [dict get $argd opts -return] + #set opt_eval [dict get $argd opts -eval] + + set templatestring [lindex $args end] + set arglist [lrange $args 0 end-1] + set opts [dict create\ + -allowcommands 0\ + -undent 1\ + -indent ""\ + -paramindents line\ + -eval 1\ + -return string\ + ] + if {"-allowcommands" in $arglist} { + set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] + dict set opts -allowcommands 1 + } + if {[llength $arglist] % 2 != 0} { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr expected option/value pairs prior to last argument" + } + } + dict for {k v} $arglist { + set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] + switch -- $fullk { + -indent - -undent - -paramindents - -return - -eval { + dict set opts $fullk $v + } + default { + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::lib::tstr $args + return + } else { + error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + } + } + } + } + set opt_allowcommands [dict get $opts -allowcommands] + set opt_paramindents [dict get $opts -paramindents] + set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] + if {$test_paramindents ni {none line position}} { + error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." + } + set opt_paramindents $test_paramindents + set opt_return [dict get $opts -return] + set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] + if {$opt_return eq ""} { + } + set opt_eval [dict get $opts -eval] + + + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + set opt_undent [dict get $opts -undent] + if {$opt_undent} { + set templatestring [punk::args::lib::undent $templatestring] + } + set opt_indent [dict get $opts -indent] + if {$opt_indent ne ""} { + set templatestring [punk::args::lib::indent $templatestring $opt_indent] + } + + #set parts [_tstr_split $templatestring] + if {[string first \$\{ $templatestring] < 0} { + set parts [list $templatestring] + } else { + set parts [_parse_tstr_parts $templatestring] + } + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + set errors [dict create] + set lastline "" ;#todo - first line has placeholder? + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + #lappend expressions $expression + #---------------------- + #REVIEW - JMN + #TODO - debug punk::args loading of @dynamic defs + #puts "-- $expression" + #---------------------- + #brk1 - literal newline not {\n} + set leader "" + if {[set brk1 [string first \n $expression]] >= 0} { + #undent left of paramstart only for lines of expression that arent on opening ${..} line + set tail [string range $expression $brk1+1 end] + set leader [string repeat " " [string length $lastline]] + set undentedtail [punk::args::lib::undentleader $tail $leader] + #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] + set expression "[string range $expression 0 $brk1]$undentedtail" + } + if {$opt_eval} { + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + set result [string map [list \n "\n$leader"] $result] + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + } else { + lappend params [subst -nocommands -novariables $expression] + } + append lastline [lindex $params end] ;#for current expression's position calc + + incr idx ;#expression incr + } + + if {$opt_return eq "dict"} { + return [dict create template $textchunks params $params errors $errors] + } + if {[dict size $errors]} { + set einfo "" + dict for {i e} $errors { + append einfo "parameter $i error: $e" \n + } + #REVIEW!!! + #TODO - fix + #puts stderr "tstr errors:\n$einfo\n" + } + + switch -- $opt_return { + list { + return [list $textchunks $params] + } + args { + #see example in tstr_test_one + return [list $textchunks {*}$params] + } + string { + #todo - flag to disable indent-matching behaviour for multiline param? + set out "" + set pt1 [lindex $parts 0] + set lastline_posn [string last \n $pt1] + if {$lastline_posn >= 0} { + set lastline [string range $pt1 $lastline_posn+1 end] + } else { + set lastline $pt1 + } + foreach pt $textchunks param $params { + if {$opt_paramindents eq "none"} { + append out $pt $param + } else { + set lastline_posn [string last \n $pt] + if {$lastline_posn >= 0} { + set lastline [string range $pt $lastline_posn+1 end] + } + if {$opt_paramindents eq "line"} { + regexp {(\s*).*} $lastline _all lastindent + } else { + #position + #TODO - detect if there are grapheme clusters + #This regsub doesn't properly space unicode double-wide chars or clusters + set lastindent "[regsub -all {\S} $lastline " "] " + } + if {$lastindent ne ""} { + set paramlines [split $param \n] + if {[llength $paramlines] == 1} { + append out $pt $param + } else { + append out $pt [lindex $paramlines 0] + foreach nextline [lrange $paramlines 1 end] { + append out \n $lastindent $nextline + } + } + } else { + append out $pt $param + } + append lastline $param + } + } + return $out + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::parse $args withdef { + @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + } + + @values -min 2 -max 2 + template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the tstr call in the example does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} + }] + set template [dict get $argd values template] + set where [dict get $argd values where] + #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + set result [string cat [lindex $template 0] $where [lindex $template 1]] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket dollar sign + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + + #hacky + proc undentleader {text leader} { + #leader usually whitespace - but doesn't have to be + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + lappend nonblank "${leader}!!" + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + #regexp {^([\t ]*)} $lcp _m lcp + #lcp can be shorter than leader + set lcp [string range $lcp 0 [string length $leader]-1] + + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] +} + +tcl::namespace::eval punk::args::argdocbase { + namespace export * + #use a? to test and create literal ansi here rather than relying on punk::ansi package presence + #e.g + #% a? bold + #- bold │SGR 1│sample│␛[1msample + #- ──────┼─────┼──────┼────────── + #- RESULT│ │sample│␛[1msample + proc B {} {return \x1b\[1m} ;#a+ bold + proc N {} {return \x1b\[22m} ;#a+ normal + proc I {} {return \x1b\[3m} ;#a+ italic + proc NI {} {return \x1b\[23m} ;#a+ noitalic + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::args::package { + variable PUNKARGS + lappend PUNKARGS [list { + @dynamic + @id -id "::punk::args::package::standard_about" + @cmd -name "%pkg%::about" -help\ + "About %pkg% + ... + " + -package_about_namespace -type string -optional 0 -help\ + "Namespace containing the package about procedures + Must contain " + -return\ + -type string\ + -default table\ + -choices {string table tableobject}\ + -choicelabels { + string\ + "A basic text layout" + table\ + "layout in table borders + (requires package: textblock)" + tableobject\ + "textblock::class::table object instance" + }\ + -help\ + "Choose the return type of the 'about' information" + topic -optional 1\ + -nocase 1\ + -default {*}\ + -choices {Description License Version Contact *}\ + -choicerestricted 0\ + -choicelabels { + + }\ + -multiple 1\ + -help\ + "Topic to display. Omit or specify as * to see all. + If * is included with explicit topics, * represents + the remaining unmentioned topics." + }] + proc standard_about {args} { + set argd [punk::args::parse $args withid ::punk::args::package::standard_about] + lassign [dict values $argd] leaders OPTS values received + + set pkgns [dict get $OPTS -package_about_namespace] + if {[info commands ${pkgns}::package_name] eq ""} { + error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" + } + set pkgname [${pkgns}::package_name] + + set opt_return [dict get $OPTS -return] + set all_topics [${pkgns}::about_topics] + if {![dict exists $received topic]} { + set topics $all_topics + } else { + # * represents all remaining topics not explicitly mentioned. + set val_topics [dict get $values topic] ;#if -multiple is true, this is a list + set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] + set topics [list] + foreach t $val_topics { + if {$t eq "*"} { + foreach a $all_topics { + if {$a ni $explicit_topics} { + lappend topics $a + } + } + } else { + lappend topics $t + } + } + } + if {$opt_return ne "string"} { + package require textblock ;#table support + set is_table 1 + set title [string cat {[} $pkgname {]} ] + set t [textblock::class::table new -title $title] + $t configure -frametype double -minwidth [expr {[string length $title]+2}] + + } else { + set topiclens [lmap t $topics {string length $t}] + set widest_topic [tcl::mathfunc::max {*}$topiclens] + set is_table 0 + set about "$pkgname\n" + append about [string repeat - $widest_topic] \n + } + foreach topic $topics { + if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { + set topic_contents [::${pkgns}::get_topic_$topic] + } else { + set topic_contents "" + } + if {!$is_table} { + set content_lines [split $topic_contents \n] + append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n + foreach ln [lrange $content_lines 1 end] { + append about [format %-${widest_topic}s ""] " " $ln \n + } + } else { + $t add_row [list $topic $topic_contents] + } + } + + if {!$is_table} { + return $about + } else { + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } + +} + +#usually we would directly call arg definitions near the defining proc, +# so that the proc could directly use the definition in its parsing. +# +#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. +#arguably it may be more processor-cache-efficient to do together like this anyway. + +#can't do this here? - as there is circular dependency with punk::lib +#tcl::namespace::eval punk::args { +# foreach deflist $PUNKARGS { +# punk::args::define {*}$deflist +# } +# set PUNKARGS "" +#} + +lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::args::system { + #*** !doctools + #[subsection {Namespace punk::args::system}] + #[para] Internal functions that are not part of the API + + #dict get value with default wrapper for tcl 8.6 + if {[info commands ::tcl::dict::getdef] eq ""} { + proc Dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef + } + + #name to reflect maintenance - home is punk::lib::ldiff + proc punklib_ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::args [tcl::namespace::eval punk::args { + tcl::namespace::path {::punk::args::lib ::punk::args::system} + variable pkg punk::args + variable version + set version 0.1.7 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm index 42b97126..509e3939 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm @@ -141,17 +141,20 @@ tcl::namespace::eval punk::args::tclcore { variable PUNKARGS - package require punk::ansi - tcl::namespace::import ::punk::ansi::a+ - # -- --- --- --- --- - #non colour SGR codes - # we can use these directly via ${$I} etc without marking a definition with @dynamic - #This is because they don't need to change when colour switched on and off. - set I [a+ italic] - set NI [a+ noitalic] - set B [a+ bold] - set N [a+ normal] - # -- --- --- --- --- + namespace eval argdoc { + package require punk::ansi + tcl::namespace::import ::punk::ansi::a+ + tcl::namespace::import ::punk::args::tclcore::manpage_tcl + # -- --- --- --- --- + #non colour SGR codes + # we can use these directly via ${$I} etc without marking a definition with @dynamic + #This is because they don't need to change when colour switched on and off. + set I [a+ italic] + set NI [a+ noitalic] + set B [a+ bold] + set N [a+ normal] + # -- --- --- --- --- + } namespace eval argdoc { @@ -180,13 +183,15 @@ tcl::namespace::eval punk::args::tclcore { proc ensemble_subcommands_definition {args} { #args manually parsed - with use of argdef for unhappy-path only if {![llength $args]} { - punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition return } set ensemble [lindex $args end] set optlist [lrange $args 0 end-1] if {[llength $optlist] % 2} { - punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition return } set defaults [dict create\ @@ -198,7 +203,8 @@ tcl::namespace::eval punk::args::tclcore { switch -- $k { -groupdict - -columns {} default { - punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args + punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition return } } @@ -255,12 +261,30 @@ tcl::namespace::eval punk::args::tclcore { dict for {g members} $opt_groupdict { lappend allgrouped {*}$members } - foreach sc $allsubs { + set choiceinfodict [dict create] + foreach {sc cmd} $subdict { if {$sc ni $allgrouped} { if {$sc ni $others} { lappend others $sc } } + set cinfo [punk::ns::resolve_command {*}$cmd] + set tp [dict get $cinfo cmdtype] + + dict set choiceinfodict $sc [list [list resolved $cmd]] + + switch -- $tp { + ensemble - native { + dict lappend choiceinfodict $sc [list doctype $tp] + } + object { + dict lappend choiceinfodict $sc [list doctype oo] + } + } + + if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { + dict lappend choiceinfodict $sc {doctype punkargs} + } } set argdef "" @@ -269,7 +293,7 @@ tcl::namespace::eval punk::args::tclcore { dict for {g members} $opt_groupdict { append argdef " \"$g\" \{$members\}" \n } - append argdef " \} -choicecolumns $opt_columns" \n + append argdef " \} -choicecolumns $opt_columns -choiceinfo {$choiceinfodict}" \n #todo -choicelabels #detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. @@ -301,7 +325,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { #test of @form - @id -id ::AFTER + @id -id ::after @cmd -name "Builtin: after" -help\ "Execute a command after a time delay." @@ -310,19 +334,23 @@ tcl::namespace::eval punk::args::tclcore { "script argument to be concatenated in the same fashion as the concat command" # ---------- shared elements ------------- - @form -form {delay} -synopsis "after ms" + #@form -form {delay} -synopsis "after ms" + @form -form {delay} @form -form {schedule_ms} -synopsis "after ms ?script...?" - #@values -form {*} #note "classify next argument as a value not a leader" + #review + #@values -form {*} #note "classify next argument as a value not a leader" + #@values -form {*} + ms -form {*} -type int -help\ "milliseconds" @values -form {delay} -min 1 -max 1 @values -form {schedule_ms} -min 2 - script -form {schedule_ms} -multiple 1 -optional 1 ref-help common_script_help + script -form {schedule_ms} -multiple 1 -optional 0 ref-help common_script_help @form -form {cancelid} -synopsis "after cancel id" - @values + @values -min 2 -max 2 cancel -choices {cancel} id @@ -334,17 +362,108 @@ tcl::namespace::eval punk::args::tclcore { @form -form {schedule_idle} -synopsis "after idle script ?script...?" - @values -min 1 + @values -min 2 idle -choices {idle} - script -multiple 1 -optional 1 ref-help common_script_help + script -multiple 1 -optional 0 ref-help common_script_help @form -form {info} -synopsis "after info ?id?" + @values -min 0 -max 2 info -choices {info} id -optional 1 } "@doc -name Manpage: -url [manpage_tcl after]" ] namespace eval argdoc { + punk::args::define { + @id -id ::tcl::info::args + @cmd -name "BUILTIN: tcl::info::args" -help\ + "Returns the names of the parameters to the procedure named ${$I}procname${$NI}." + @values -min 1 -max 1 + procname -type string -optional 0 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::body + @cmd -name "BUILTIN: tcl::info::body" -help\ + "Returns the body procedure named ${$I}procname${$NI}." + @values -min 1 -max 1 + procname -type string -optional 0 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::default + @cmd -name "BUILTIN: tcl::info::default" -help\ + "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} + has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. + Otherwise, returns ${$B}0${$N}." + @values -min 3 -max 3 + procname -type string -optional 0 + parameter + varname + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::tcl::info::cmdtype + @cmd -name "Builtin: tcl::info::cmdtype" -help\ + "Returns the type of the command named ${$I}commandName${$NI}. + Built-in types are: + ${$B}alias${$N} + ${$I}commandName${$NI} was created by 'interp alias'. In a safe interpreter an + alias is only visible if both the alias and the target are visible. + ${$B}coroutine${$N} + ${$I}commandName${$NI} was created by 'coroutine'. + ${$B}ensemble${$N} + ${$I}commandName${$NI} was created by 'namespace ensemble'. + ${$B}import${$N} + ${$I}commandName${$NI} was created by 'namespace import'. + ${$B}native${$N} + ${$I}commandName${$NI} was created by the 'Tcl_CreateObjCommand' interface + directly without further registration of the type of command. + ${$B}object${$N} + ${$I}commandName${$NI} is the public comand that represents an instance + of oo::object or one of its subclasses. + ${$B}privateObject${$N} + ${$I}commandName${$NI} is the private command, my by default, + that represents an instance of oo::object or one of its subclasses. + ${$B}proc${$N} + ${$I}commandName${$NI} was created by 'proc'. + ${$B}interp${$N} + ${$I}commandName${$NI} was created by 'interp create'. + ${$B}zlibStream${$N} + ${$I}commandName${$NI} was created by 'zlib stream'. + " + @values -min 1 -max 1 + commandName -type string + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" + + punk::args::define { + @id -id ::oo::InfoObject::call + @cmd -name "Builtin: oo::InfoObject::call" -help\ + "Returns a description of the method implementations that are used to provide + ${$I}object's${$NI} implementation of ${$I}method${$NI}. This consists of a + list of lists of four elements, where each sublist consists of: + element 0: a word that describes the general type of method implementation, being + one of + ${$B}method${$N} for an ordinary method, ${$B}filter${$N} for an applied filter, + ${$B}private${$N} for a private method, and ${$B}unknown${$N} for a method that + is invoked as part of unknown method handling. + element 1: a word giving the name of the particular method invoked (which is always + the same as method for the ${$B}method${$N} type, and \"${$B}unknown${$N}\" + for the ${$B}unknown${$N} type) + element 2: a word giving what defined the method (the fully qualified name of the + class, or the literal string ${$B}object${$N} if the method implementation is on + an instance) + element 3: a word describing the type of method implementation + (see ${$B}info object methodtype${$N} + + Note that there is no inspection of whether the method implementations actually use + ${$B}next${$N} to transfer control along the call chain, and the call chains that + this command files do not actually contain private methods." + @values -min 2 -max 2 + object + method + } "@doc -name Manpage: -url [manpage_tcl info]" + #todo - make generic - take command and known_groups_dict proc info_subcommands {} { #package require punk::ns @@ -357,17 +476,18 @@ tcl::namespace::eval punk::args::tclcore { return [ensemble_subcommands_definition -groupdict $groups -columns 4 info] } + set DYN_INFO_SUBCOMMANDS {${[punk::args::tclcore::argdoc::info_subcommands]}} + lappend PUNKARGS [list { + @dynamic + @id -id ::info + @cmd -name "Builtin: info" -help\ + "Information about the state of the Tcl interpreter" + @leaders -min 1 -max 1 + ${$DYN_INFO_SUBCOMMANDS} + @values -min 0 + + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl array]" ] } - lappend PUNKARGS [list { - @dynamic - @id -id ::info - @cmd -name "Builtin: info" -help\ - "Information about the state of the Tcl interpreter" - @leaders -min 1 -max 1 - ${[punk::args::tclcore::argdoc::info_subcommands]} - @values -min 0 - - } "@doc -name Manpage: -url [manpage_tcl array]" ] @@ -396,6 +516,7 @@ tcl::namespace::eval punk::args::tclcore { } ] lappend PUNKARGS [list { @id -id "::tcl::binary::decode::base64" + @default -id (default)::tcl::binary::*::base64 @cmd -name "binary decode base64" -strict -type none -help\ "Instructs the decoder to throw an error if it encounters any characters that @@ -429,7 +550,7 @@ tcl::namespace::eval punk::args::tclcore { characters. Otherwise it ignores them." @values -min 1 -max 1 data -type string - } "@doc -name Manpage: -url [manpage_tcl binary]" ] + }] lappend PUNKARGS [list { @@ -474,6 +595,23 @@ tcl::namespace::eval punk::args::tclcore { data -type string } ] + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id "::tcl::encoding::dirs" + @cmd -name "encoding dirs" -help\ + "Tcl can load encoding data files from the file system that describe + additional encodings for it to work with. This command sets the search + path for ${$B}*.enc${$N} encoding data files to the list of directories + ${$I}directoryList${$NI}. If ${$I}directoryList${$NI} is omitted then the + command returns the current list of directories that make up the search + path. It is an error for ${$I}directoryList${$NI} to not be a valid list. + If, when a search for an encoding data file is happening, an element in + ${$I}directoryList${$NI} does not refer to a readable, searchable + directory, that element is ignored." + @values -min 0 -max 1 + directoryList -optional 1 -type list + } "@doc -name Manpage: -url [manpage_tcl encoding]" ] + } lappend PUNKARGS [list { @id -id ::time @@ -491,6 +629,119 @@ tcl::namespace::eval punk::args::tclcore { count -type integer -default 1 -optional 1 } "@doc -name Manpage: -url [manpage_tcl time]" ] + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tcl::chan::blocked + @cmd -name "Builtin: tcl::chan::blocked" -help\ + "This tests whether the last input operation on the channel called ${$I}channel${$NI} + failed because it would otherwise have caused the process to block, and returns 1 + if that was the case. It returns 0 otherwise. Note that this only ever returns 1 + when the channel has been configured to be non-blocking; all Tcl channels have + blocking turned on by default" + @values -min 1 -max 1 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + #close + lappend PUNKARGS [list { + @id -id ::fconfigure + @cmd -name "Builtin: chan configure" -help\ + "Query or set the configuration options of the channel named ${$I}channel${$NI} + If no ${$I}optionName${$NI} or ${$I}value${$NI} arguments are supplied, the + command returns a list containing alternating option names and values for the + channel. If ${$I}optionName${$NI} is supplied but no ${$I}value${$NI} then the + command returns the current value of the given option. If one or more pairs + of ${$I}optionName${$NI} and ${$I}value${$NI} are supplied, the command sets each + of the named options to the corresponding value; in this case the return + value is an empty string. + + The options described below are supported for all channels. In addition, each + channel type may add options that only it supports. See the manual entry for + the command that creates each type of channel for the options supported by + that specific type of channel. For example, see the manual entry for the + ${$B}socket${$N} command for additional options for sockets, and the ${$B}open${$N} + command for additional options for serial devices. + ${$B}-blocking${$N} ${$I}boolean${$NI} + The ${$B}-blocking${$N} option determines whether I/O operations on the + channel can cause the process to block indefinitely. The value of the + option must be a proper boolean value. Channels are normally in blocking + mode; if a channel is placed into non-blocking mode it will affect the + operation of the ${$B}chan gets, chan read, chan puts, chan flush,${$N} + and ${$B}chan close${$N} commands; see the documentation for those + commands for details. For non-blocking mode to work correctly, the + application must be using the Tcl event loop (e.g. by calling + ${$B}Tcl_DoOneEvent${$N} or invoking the ${$B}vwait${$N} command). + ${$B}-buffering${$N} ${$I}newValue${$NI} + + ${$B}-buffersize${$N} ${$I}newSize${$NI} + + ${$B}-encoding${$N} ${$I}name${$NI} + + ${$B}-eofchar${$N} ${$I}char${$NI} + + ${$B}-profile${$N} ${$I}profile${$NI} + + ${$B}-translation${$N} ${$I}translation${$NI}" + + @form -form {getall} + @values -min 1 -max 1 + channel + @form -form {getone} + @values -min 2 -max 2 + channel + optionName + + @form -form {set} + @values -min 3 -max -1 + channel + "optionName value" -type {string any} -multiple 1 -optional 0 + + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + + lappend PUNKARGS [list { + @id -id ::tcl::chan::eof + @cmd -name "Builtin: tcl::chan::eof" -help\ + "Test whether the last input operation on the channel called ${$I}channel${$NI} + failed because the end of the data stream was reached, returning 1 if end-of-file + was reached, and 0 otherwise." + @values -min 1 -max 1 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + #event + #flush + #gets + #isbinary + #names + #pending + lappend PUNKARGS [list { + @id -id ::tcl::chan::pipe + @cmd -name "Builtin: tcl::chan::pipe" -help\ + "Creates a standalone pipe whose read- and write-side channels are returned + as a 2-element list, the first element being the read side and the second + write side. Can be useful e.g. to redirect separately ${$B}stderr${$N} and ${$B}stdout${$N} + from a subprocess. To do this spawn with \"2>@\" or \">@\" redirection + operators onto the write side of a pipe, and then immediately close it + in the parent. This is necessary to get an EOF on the read side once the + child has exited or otherwise closed its output. + Note that the pipe buffering semantics can vary at the operating system + level substantially; it is not safe to assume that a write performed on + the output side of the pipe will appear instantly to the input side. + This is a fundamental difference and Tcl cannot conceal it. The overall + stream semantics ${$I}are${$NI} compatible, so blocking reads and writes + will not see most of the differences, but the details of what exactly gets + written when are not. This is most likely to show up when using pipelines + for testing; care should be taken to ensure that deadlocks do not occur + and that potential short reads are allowed for." + @values -min 0 -max 0 + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + + } lappend PUNKARGS [list { @id -id ::tcl::chan::tell @@ -501,11 +752,12 @@ tcl::namespace::eval punk::args::tclcore { to set the channel to a particular position. Note that this value is in terms of bytes, not characters like ${[a+ bold]}chan read${[a+ normal]}. The value returned is -1 for channels that do not support seeking." - @values + @values -min 1 -max 1 channel -help \ "" } "@doc -name Manpage: -url [manpage_tcl chan]" ] + lappend PUNKARGS [list { @id -id ::tcl::chan::truncate @cmd -name "Builtin: tcl::chan::truncate" -help\ @@ -513,52 +765,305 @@ tcl::namespace::eval punk::args::tclcore { length (or to the current byte offset within the underlying data stream if length is omitted). The channel is flushed before truncation." #todo - auto synopsis? - @form -synopsis\ - "chan truncate channel ?length?" - @values + #@form -synopsis\ + # "chan truncate channel ?length?" + @values -min 1 -max 2 channel -help \ "" length -optional 1 -type integer } "@doc -name Manpage: -url [manpage_tcl chan]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #dict + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tcl::dict::append + @cmd -name "Builtin: tcl::dict::append" -help\ + "This appends the given string (or strings) to the value that the given + key maps to in the dictionary value contained in the given variable, + writing the resulting dictionary value back to that variable. Non-existant + keys are treated as if they map to an empty string. The updated dictionary + value is returned." + @values -min 2 -max -1 + dictionaryVariable -type string -help \ + "" + key + string -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::create + @cmd -name "Builtin: tcl::dict::create" -help\ + "Return a new dictionary that contains each of the key/value mappings listed + as arguments (keys and values alternating, with each key being followed by + its associated value)" + @values -min 2 -max -1 + "key value" -type {string string} -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::exists + @cmd -name "Builtin: tcl::dict::exists" -help\ + "This returns a boolean value indicating whether the given key (or path of + keys through a set of nested dictionaries) exists in the given dictionary + value. This returns a true value exactly when ${$B}dict get${$N} on that path will + succeed." + @values -min 2 -max -1 + dictionaryValue -type dict + key -type string -multiple 1 -optional 0 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::dict::replace + @cmd -name "Builtin: tcl::dict::replace" -help\ + "Return a new dictionary that is a copy of an old one passed in as first + argument except with some values different or some extra key/value pairs + added. It is legal for this command to be called with no key/value pairs, + but illegal for this command to be called with a key but no value." + @values -min 1 -max -1 + dictionaryValue -type dict + "key value" -type {string string} -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl dict]" ] + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #file + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::tcl::file::channels + @cmd -name "Builtin: tcl::file::channels" -help\ + "If ${$I}pattern${$NI} is not specified, returns a list of names of all + registered copen channels in this interpreter. If ${$I}pattern${$NI} is + specified, only those names matching ${$I}pattern${$NI} are returned. + Matching is determined using the same rules as for string match." + @opts -prefix 0 + @values -min 0 -max -1 + pattern -optional 1 -type string -default * + } "@doc -name Manpage: -url [manpage_tcl file]" ] - #TODO - autocreate argdef namespace and import B N etc - # ${[B]import[N]} - lappend PUNKARGS [list { - @id -id ::tcl::info::cmdtype - @cmd -name "Builtin: tcl::info::cmdtype" -help\ - "Returns the type of the command named ${$I}commandName${$NI}. - Built-in types are: - ${$B}alias${$N} - ${$I}commandName${$NI} was created by 'interp alias'. In a safe interpreter an - alias is only visible if both the alias and the target are visible. - ${$B}coroutine${$N} - ${$I}commandName${$NI} was created by 'coroutine'. - ${$B}ensemble${$N} - ${$I}commandName${$NI} was created by 'namespace ensemble'. - ${$B}import${$N} - ${$I}commandName${$NI} was created by 'namespace import'. - ${$B}native${$N} - ${$I}commandName${$NI} was created by the 'Tcl_CreateObjCommand' interface - directly without further registration of the type of command. - ${$B}object${$N} - ${$I}commandName${$NI} is the public comand that represents an instance - of oo::object or one of its subclasses. - ${$B}privateObject${$N} - ${$I}commandName${$NI} is the private command, my by default, - that represents an instance of oo::object or one of its subclasses. - ${$B}proc${$N} - ${$I}commandName${$NI} was created by 'proc'. - ${$B}interp${$N} - ${$I}commandName${$NI} was created by 'interp create'. - ${$B}zlibStream${$N} - ${$I}commandName${$NI} was created by 'zlib stream'. - " - @values -min 1 -max 1 - commandName -type string - } "@doc -name Manpage: -url [manpage_tcl info]" ] + lappend PUNKARGS [list { + @id -id ::tcl::file::delete + @cmd -name "Builtin: tcl::file::delete" -help\ + "Removes the file or directory specified by each ${$I}pathname${$NI} argument. + Non-empty directories will be removed only if the ${$B}-force${$N} option is + specified. When operating on symbolic links, the links themselves will be + deleted, not the objects they point to. Trying to delete a non-existent file + is not considered an error. Trying to delete a read-only file will cause the + file to be deleted, even if the ${$B}-force${$N} flag is not specified. If the ${$B}-force${$N} + flag is specified on a directory, Tcl will attempt both to change permissions + and move the current directory \"pwd\" out of the given path if that is + necessary to allow the deletion to proceed. Arguments are processed in the + order specified, halting at the first error, if any. A -- marks the end of + switches; the argument following the -- will be treated as a ${$I}pathname${$NI} + even if it starts with a -." + @opts -prefix 0 + -force -optional 1 -type none + -- -optional 1 -type none + @values -min 0 -max -1 + pathname -optional 1 -type string -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::copy + @cmd -name "Builtin: tcl::file::copy" -help\ + "The first form makes a copy of the file or directory ${$I}source${$NI} under the pathname ${$I}target${$NI}. + If ${$I}target${$NI} is an existing directory then the second form is used. + The second form makes a copy inside ${$I}targetDir${$NI} of each ${$I}source${$NI} file listed. + If a directory is specified as a ${$I}source${$NI}, then the contents of the directory will be + recursiveley copied into ${$I}targetDir${$NI}. Existing files will not be overwritten unless the + ${$B}-force${$N} options is specified (when Tcl will also attempt to adjust permissions on the destination + file or directory if that is necessary to allow the copy to proceed). + When copying within a single filesystem, ${$I}file copy${$NI} will copy soft links (i.e the links themselves + are copied, not the things they point to.) Trying to overwrite a non-empty directory, overwrite a directory + with a file, or overwrite a file with a directory will all result in errors even if ${$B}-force${$N} was + specified. + Arguments are processed in the order specified, halting at the first error, if any. A -- marks the end of + switches; the argument following the -- will be treated as a ${$I}source${$NI} even if it starts with a -." + @form -form {topath inpath} + @opts -form {*} -prefix 0 + -force -optional 1 -type none + -- -optional 1 -type none + + @form -form "topath" + @values -min 2 -max 2 + source -type string -help\ + "file or directory" + target -type string + + @form -form "inpath" + @values -min 2 -max -1 + source -type string -multiple 1 -help\ + "file or directory" + targetDir -optional 1 -type existingdir + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::executable + @cmd -name "Builtin: tcl::file::executable" -help\ + "Returns ${$B}1${$N} if file ${$I}name${$NI} is executable by the current user, ${$B}0${$N} + otherwise. On Windows, which does not have an executable attribute, the command treats + all directories and any files with extensions ${$B}exe${$N}, ${$B}com${$N}, ${$B}cmd${$N} or ${$B}bat${$N} as executable." + @values -min 0 -max 1 + name -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::exists + @cmd -name "Builtin: tcl::file::exists" -help\ + "Returns ${$B}1${$N} if the file ${$I}name${$NI} exists and the current user has search + privileges for the directories leading to it, ${$B}0${$N} otherwise." + @values -min 0 -max 1 + name -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::extension + @cmd -name "Builtin: tcl::file::extension" -help\ + "Returns all of the characters in ${$I}name${$NI} after and including the last dot in the last + element of name. If there is no dot in the last element of ${$I}name${$NI} then returns the + empty string." + @values -min 0 -max 1 + name -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::home + @cmd -name "Builtin: tcl::file::home" -help\ + "If no argument is specified, the command returns the home directory of the current user. + This is generally the value of the ${$B}$HOME${$N} environment variable except that on Windows + platforms backslashes in the path are replaced by forward slashes. An error is raised if + the ${$B}$HOME${$N} environment variable is not set. + if ${$I}username${$NI} is specified, the command returns the home directory configured in the + system for the specified user. Note this may be different that the value of the ${$B}$HOME${$N} + environment variable even when the ${$I}username${$NI} corresponds to the current user. + An error is raised if the ${$I}username${$NI} does not correspond to a user account on the system." + @values -min 0 -max 1 + username -optional 1 -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::isdirectory + @cmd -name "Builtin: tcl::file::isdirectory" -help\ + "Returns ${$B}1${$N} if the file name is a directory, ${$B}0${$N} otherwise." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::isfile + @cmd -name "Builtin: tcl::file::isfile" -help\ + "Returns ${$B}1${$N} if the file name is a regular file, ${$B}0${$N} otherwise." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + #join + #link + #lstat + + lappend PUNKARGS [list { + @id -id ::tcl::file::mkdir + @cmd -name "Builtin: tcl::file::mkdir" -help\ + "Creates each directory specified. + For each pathname ${$I}dir${$NI} specified, this command will create all non-existing parent directories + as well as ${$I}dir${$NI} itself. If an existing directory is specified, then no action is taken and no + error is returned. Trying to overwrite an existing file with a directory will result in an error. + Arguments are processed in the order specified, halting at the first error, if any." + @values -min 0 -max -1 + dir -optional 1 -type string -multiple 1 + #dir -optional 1 -type directory -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl file]" ] + + lappend PUNKARGS [list { + @id -id ::tcl::file::mtime + @cmd -name "Builtin: tcl::file::mtime" -help\ + "Returns a decimal string giving the time at which file ${$I}name${$NI} was last modified. + If ${$I}time${$NI} is specified, it is a modification time to set for the file (equivalent + to Unix ${$B}touch${$N}). The time is measured in the standard POSIX fashion as seconds + from a fixed starting time (often January 1, 1970). If the file does not exist or its + modified time cannot be queried or set then an error is generated. on ${$B}zipfs${$N} + file systems, modification time cannot be explicitly set." + @values -min 1 -max 2 + name -type string + time -type integer -optional 1 + } "@doc -name Manpage: -url [manpage_tcl file]"] + #nativename + #normalize + #owned + #pathtype + lappend PUNKARGS [list { + @id -id ::tcl::file::readable + @cmd -name "Builtin: tcl::file::readable" -help\ + "Returns ${$B}1${$N} if the file ${$I}name${$NI} is readable by the current user, ${$B}0${$N} otherwise." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]"] + #readlink + #rename (2 forms) + #rootname + #separator + #size + #split + #stat + #system + #tail + #tempdir + #tempfile + #tildeexpand + #type + #volumes + lappend PUNKARGS [list { + @id -id ::tcl::file::writable + @cmd -name "Builtin: tcl::file::writable" -help\ + "Returns ${$B}1${$N} if the file ${$I}name${$NI} is writable by the current user, ${$B}0${$N} otherwise." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]"] + + + } + namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::mathfunc::abs + @cmd -name "Builtin: tcl::mathfunc::abs" -help\ + "Returns the absolute value of ${$I}arg${$NI}. ${$I}Arg${$NI} may be either integer + or floating-point, and the result is returned in the same form." + @values -min 1 -max 1 + #review - NaN shouldn't be accepted - specify a range to exclude it. + arg -type number -range {-Inf Inf} + } "@doc -name Manpage: -url [manpage_tcl mathfunc]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::mathfunc::acos + @cmd -name "Builtin: tcl::mathfunc::acos" -help\ + "Returns the arc cosine of ${$I}arg${$NI}, in the range [0,pi] radians. + ${$I}Arg${$NI} should be in the range [-1,1]." + @values -min 1 -max 1 + arg -type number -range {-1 1} + } "@doc -name Manpage: -url [manpage_tcl mathfunc]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #asin + #atan + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::tcl::mathfunc::atan2 + @cmd -name "Builtin: tcl::mathfunc::atan2" -help\ + "Returns the arc tangent of ${$I}y/x${$NI}, in the range [-pi,pi] radians. + ${$I}x${$NI} and ${$I}y${$NI} cannot both be 0. If ${$I}x${$NI} is greater + than 0, this is equivalent to \"${$B}atan [expr {y/x}]${$N}\"." + @values -min 2 -max 2 + y -type number + x -type number + } "@doc -name Manpage: -url [manpage_tcl mathfunc]" ] + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @id -id ::tcl::namespace::origin @cmd -name "Builtin: tcl::namespace::origin" -help\ @@ -618,8 +1123,9 @@ tcl::namespace::eval punk::args::tclcore { regarding name resolution. " @opts - -command - -variable + -command -type none + #todo - make mutually exclusive - (separate forms) + -variable -type none @values -min 1 -max 1 name } "@doc -name Manpage: -url [manpage_tcl namespace]" ] @@ -700,16 +1206,97 @@ tcl::namespace::eval punk::args::tclcore { } } - lappend PUNKARGS [list { - @dynamic - @id -id ::array - @cmd -name "Builtin: array" -help\ - "Manipulate array variables" - @values - ${[punk::args::tclcore::argdoc::array_subcommands]} + namespace eval argdoc { + lappend PUNKARGS [list { + @dynamic + @id -id ::append + @cmd -name "Builtin: append" -help\ + "Append to variable + Append al of the ${$I}value${$NI} arguments to the current value of variable + ${$I}varName${$NI}. if ${$I}varName${$NI} does not exist, it is given a value equal + to the concatenation of all the ${$I}value${$NI} arguments. + if ${$I}varName indicates an element that does not exist of an array that has a default value + set, the concatenation of the default value and all the ${$I}value${$NI} arguments will be stored + in the array element. + The result of this command is the new value stored in variable ${$I}varName${$NI}. + This command privides an efficient way to build up long variables incrementally. + For example, \"${$B}append a $b${$N}\" is much more efficient than \"${$B}set a $a$b${$N}\" + if ${$B}$a${$N} is long." + @values -min 1 + varName -optional 0 + value -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl append]" ] + + } - } "@doc -name Manpage: -url [manpage_tcl array]" ] + namespace eval argdoc { + lappend PUNKARGS [list { + @dynamic + @id -id ::array + @cmd -name "Builtin: array" -help\ + "Manipulate array variables" + @leaders + ${[punk::args::tclcore::argdoc::array_subcommands]} + } "@doc -name Manpage: -url [manpage_tcl array]" ] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + lappend PUNKARGS [list { + @id -id ::tcl::array::default + @cmd -name "Builtin: array default" -help\ + "Manages the default value of the array. + Arrays initially have no default value, but this command allows you to set one; + the default value will be returned when reading from an element of the array + ${$I}arrayName${$NI} if the read would otherwise result in an error. + Note that this may cause the ${$B}append${$N}, ${$B}dict${$N}, ${$B}incr${$N} and ${$B}lappend${$N} + commands to change their behaviour in relation to non-existing array elements." + + @form -form exists + @leaders + exists -type literal -help\ + "This returns a boolean value indicating whether a default value has + been set for the array ${$I}arrayName${$NI}. Returns a false value if + ${$I}arrayName${$NI} does not exist. Raises an error if ${$I}arrayName${$NI} + is an existing variable that is not an array." + @values -min 1 -max 1 + arrayName + + @form -form get + @leaders + get -type literal -help\ + "This returns the current default value for the array ${$I}arrayName${$NI}. + Raises an error if ${$I}arrayName${$NI} is an existing variable that is + not an array, or if ${$I}arrayName${$NI} is an array without a default value." + @values -min 1 -max 1 + arrayName + + @form -form set + @leaders + set -type literal -help\ + "This sets the default value for the array ${$I}arrayName${$NI} to ${$I}value${$NI}. + Returns the empty string. Raises an error if ${$I}arrayName${$NI} is an existing + variable that is not an array, or if ${$I}arrayName${$NI} is an illegal name for an + array. If ${$I}arrayName${$NI} does not currently exist, it is created as an empty + array as well as having its default value set." + @values -min 2 -max 2 + arrayName + value + + @form -form unset + @leaders + unset -type literal -help\ + "This removes the default value for the array ${$I}arrayName${$NI} and returns + the empty string. Does nothing if ${$I}arrayName${$NI} does not have a default + value. Raises an error if ${$I}arrayName${$NI} is an existing variable that is + not an array." + @values -min 1 -max 1 + arrayName + + + } "@doc -name Manpage: -url [manpage_tcl array]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -741,6 +1328,67 @@ tcl::namespace::eval punk::args::tclcore { } "@doc -name Manpage: -url [manpage_tcl const]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::expr + @cmd -name "Builtin: expr" -help\ + "Evaluate an expression. + Concatenates ${$I}args${$NI}, separated by a space, into an expression, + and evaluates that expression, returning its value. The operators permitted + in an expression include a subset of the operators permitted in C expressions. + For those operators common to both Tcl and C, Tcl applies the same meaning and + precedence as the corresponding C operators. The value of an expression is + often a numeric result, either an integer or a floating-point value, but may + also be a non-numeric value. For example, the expression + ${$B}expr${$N} 8.2 + 6 + evaluates to 14.2. Expressions differ from C expressions in the way that + operands are specified. Expressions also support non-numeric operands, string + comparisons, and some additional operators not found in C. + When the result of expression is an integer, it is in decimal form, and when + the result is a floating-point number, it is in the form produced by the + ${$B}%g${$N} format specifier of ${$B}format${$N}. + At any point in the expression except within double quotes or braces, ${$B}#${$N} + is the beginning of a comment, which lasts to the end of the line or end of + the expression, whichever comes first. + (see manpage for full details)" + @values -min 1 -max -1 + arg -type string -multiple 1 -optional 0 + } "@doc -name Manpage: -url [manpage_tcl expr]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } + namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::foreach + @cmd -name "Builtin: foreach" -help\ + "The ${$B}foreach${$N} command implements a loop where the loop variable(s) + take on values from one or more lists. In the simplest case there is one loop + variable, ${$I}varname${$NI} and one list, ${$I}list${$NI}, that is a list of values + to assign to ${$I}varname${$NI}. The body argument is a Tcl script. For each element + of ${$I}list${$NI} (in order from first to last), ${$B}foreach${$N} assigns the contents + of the element to ${$I}varname${$NI} as if the ${$B}lindex${$N} command had been used + to extract the element, then calls the Tcl interpreter to execute ${$I}body${$NI}. + + In the general case there can be more than one value list, and each value list + can be associated with a list of loop variables. During each iteration of the + loop the variable of each ${$I}varlist${$NI} are assigned consecutive values from + the corresponding ${$I}list${$NI}. Values in each ${$I}list${$NI} are used in order from + first to last, and each value is used exactly once. The total number of loop + iterations is large enough to use up all the values from all the value lists. + If a value list does not contain enough elements for each of its loop variables + in each iteration, empty values are used for the missing elements. + + The ${$B}break${$N} and ${$B}continue${$N} statements may be invoked inside ${$I}body${$NI}, + with the same effect as in the ${$B}for${$N} command. + ${$B}Foreach${$N} returns an empty string." + @values + "varlist list" -type {list list} -multiple 1 -optional 0 + body -type string -optional 0 -help\ + "Tcl script" + } "@doc -name Manpage: -url [manpage_tcl foreach]" ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } ############################################################################################################################################################ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -751,175 +1399,345 @@ tcl::namespace::eval punk::args::tclcore { ############################################################################################################################################################ + namespace eval argdoc { + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::lappend + @cmd -name "builtin: lappend" -help\ + "Append list elements onto a variable. + This command treats the variable given by ${$I}listVar${$NI} as a list and + appends each of the ${$I}value${$NI} arguments to that list as a separate + element, with spaces between elements. If ${$I}listVar${$NI} does not exist, + it is created as a list with elements given by the value arguments. If + ${$I}listVar${$NI} indicates an element that does not exist of an array that + has a default value set, a list that is comprised of the default value with + all the ${$I}value${$NI} arguments appended as elements will be stored in the + array element. ${$I}Lappend${$NI} is similar to ${$I}append${$NI} except that the + values are appended as list elements rather than raw text. This command + provides a relatively efficient way to build up large lists. For example, + ${$B}\"lappend a $b\"${$N} is much more efficient than + ${$B}\"set a [concat $a [list $b]]\"${$N} when ${$B}$a${$N} is long." + @values -min 1 -max -1 + listVar -type string -help\ + "Existing list variable name" + value -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl lappend]"] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::lassign + @cmd -name "builtin: lassign" -help\ + "Assign list elements to variables. + This command treats the value ${$I}list${$NI} as a list and assigns + successive elements from that list to the variables given by the + ${$I}varName${$NI} arguments in order. If there are more variable + names than list elements, the remaining variables are set to the + empty string. If there are more list elements than variables, a + list of unassigned elements is returned." + @values -min 1 -max -1 + list -type list -help\ + "tcl list as a value" + varName -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl lassign]"] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::ledit + @cmd -name "builtin: ledit" -help\ + "Replace elements of a list stored in variable. + " + @values -min 3 -max -1 + listVar -type string -help\ + "Existing list variable name" + first -type indexexpression + last -type indexexpression + value -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl ledit]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lindex + @cmd -name "builtin: lindex" -help\ + "Retrieve an element from a list + " + @values -min 1 -max -1 + list -type list -help\ + "tcl list as a value" + index -type indexexpression -multiple 1 -optional 1 -help\ + "When no index is supplied or a single index is supplied as an empty list, + the value of the entire list is simply returned. + + If a single index is supplied and is a list of indices - this list is used + as a sequence of nested indices. + The command, + lindex $a 1 2 3 + or + lindex $l {1 2 3} + is synonymous with + lindex [lindex [lindex $a 1] 2] 3 + + When presented with a single indes, the lindex command treats list as a Tcl list + and returns the index'th element from it (0 refers to the first element of the + list). In extracting the element, lindex observes the same rules concerning + braces and quotes and backslashes as the Tcl command interpreter; however, + variable substution and command substitution do not occur. If index is negative + or greater than or equal to the number of elements in 'list', then an empty + string is returned. The interpretation of each simple index value is the same + as for the command 'string index', supporting simple index arithmetic and + indices relative to the end of the list. + + If additional index arguments are supplied, then each argument is used in turn + to select an element from the previous indexing operation, allowing the script + to select elements from sublists." + } "@doc -name Manpage: -url [manpage_tcl lindex]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::linsert + @cmd -name "builtin: linsert" -help\ + "Insert elements into a list. + This command produces a new list from ${$I}list${$NI} by insertaing all of the + ${$I}element${$NI} arguments just before the ${$I}index${$NI}'th element of list. + Each ${$I}element${$NI} argument will become a separate element of the new list. + If ${$I}index${$NI} is less than or equal to zero, then the new elements are + inserted at the beginning of the list, and if ${$I}index${$NI} is greater or equal + to the length of ${$I}list${$NI}, it is as if it was ${$B}end${$N}. + As with ${$B}string index${$N}, the ${$I}index${$NI} value supports both simple index + arithmetic and end-relative indexing. + Subject to the restrictions that indices must refer to locations inside the list and + that the ${$I}elements${$NI} will always be inserted in order, insertions are done so + that when ${$I}index${$NI} is start-relative, the first ${$I}element${$NI} will be at that + index in the resulting list, and when ${$I}index${$NI} is end-relative, the last element will + be at that index in the resulting list." + @values -min 2 -max -1 + list -type string -help\ + "tcl list as a value" + index -type indexexpression + element -type any -optional 1 -multiple 1 + @seealso -commands {list list lappend lassign ledit lindex llength lmap lpop lrange lrepeat lreplace lreverse lsearch lseq lset lsort} + } "@doc -name Manpage: -url [manpage_tcl linsert]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::list + @cmd -name "builtin: list" -help\ + "Create a list + + This command returns a list comprised of all the args, or an empty string + if no args are specified. Braces and backslashes get added as necessary, + so that the lindex command may be used on the result to re-extract the + original arguments, and also so that eval may be used to execute the + resulting list, with arg1 comprising the command's name and the other args + comprising its arguments. List produces slightly different results than + concat: concat removes one level of grouping before forming the list, + while list works directly from the original arguments." + @values -min 0 -max -1 + arg -type any -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl list]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::llength + @cmd -name "builtin: llength" -help\ + "Count the number of elements in a list. + Treats ${$I}list${$NI} as a list and returns a decimal string giving the + number of elements in it." + @values -min 1 -max 1 + list -type list -help\ + "tcl list as a value" + } "@doc -name Manpage: -url [manpage_tcl llength]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lpop + @cmd -name "builtin: lpop" -help\ + "Get and remove an element in a list. + The ${$B}lpop${$N} command acepts a parameter, ${$I}varName${$NI}, which + it interprets as the name of a variable containing a Tcl list. + It also accepts one or more ${$I}indices${$NI} into the list. If no indices + are presented, it defaults to \"${$B}end${$N}\"." + @values -min 1 -max -1 + listVar -type string -help\ + "Existing list variable name" + index -type indexexpression -default end -optional 1 -multiple 1 -help\ + "When presented with a single index, the lpop command addresses + the index'th element in it, removes it from the list and returns + the element. + If index is negative or greater or equal than the number of + elements in the list in the variable ${$I}listVar${$NI}, an error occurs. + If addition index arguments are supplied, then each argument is used + in turn to address an element within a sublist designated by the + previous indexing operation, allowing the script to remove elements + in sublists, similar to lindex and lset." + } "@doc -name Manpage: -url [manpage_tcl lpop]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lrange + @cmd -name "builtin: lrange" -help\ + "return one or more adjacent elements from a list. + The new list returned consists of elements first through last, inclusive. + The index values first and last are interpreted the same as index values + for the command 'string index', supporting simple index arithmetic and + indices relative to the end of the list. + e.g lrange {a b c} 0 end-1 + " + @values -min 3 -max 3 + list -type list -help\ + "tcl list as a value" + first -type indexexpression -help\ + "index expression for first element" + last -type indexepxression -help\ + "index expression for last element" + } "@doc -name Manpage: -url [manpage_tcl lrange]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lrepeat + @cmd -name "builtin: lrepeat" -help\ + "Build a list by repeating elements + The ${$B}lrepeat${$N} command creates a list of size count * number of + elements by repeating ${$I}count${$NI} times the sequence of elements + ${$I}element${$NI} ... count must be a non-negative integer, ${$I}element${$NI} + can be any Tcl value." + @values -min 1 -max -1 + count -type integer -range {0 ""} + element -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl lrepeat]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lreplace + @cmd -name "builtin: lreplace" -help\ + "Replace elements in a list with new elements. + ${$B}lreplace${$N} returns a new list formed by replacing zero or more + elements of ${$I}list${$NI} with the ${$I}element${$NI} arguments. + ${$I}first${$NI} and ${$I}last${$NI} are index values specifying the first + and last elements of the range to replace. The index values ${$I}first${$NI} and + ${$I}last${$NI} are interpreted the same as index values for the command ${$B}string index${$N}, + supporting simple index arithmetic and indices relative to the end of the list. + 0 refers to the first element of the list, and ${$B}end${$N} refers to the last element + of the list. + If either ${$I}first${$NI} or ${$I}last${$NI} is less than zero, it is considered + to refer to before the first element of the list. This allows ${$B}lreplace${$N} to + prepend elements to ${$I}list${$NI}. If either ${$I}first${$NI} or ${$I}last${$NI} indicates + a position greater than the index of the last element of the list, it is + treated as if it is an index one greater than the last element. This allows + ${$B}lreplace${$N} to append elements to ${$I}list${$NI}. + If ${$I}last${$NI} is less than ${$I}first${$NI}, then any specified elements will + be inserted into the list before the element specified by ${$I}first${$NI}, with + no elements being deleted. + The ${$I}element${$NI} arguments specify zero or more new elements to be added + to the list in place of those that were deleted. Each ${$I}element${$NI} argument + will become a separate element of the list. If no ${$I}element${$NI} arguments + are specified, then the elements between ${$I}first${$NI} and ${$I}last${$NI} are + simply deleted." + @values -min 3 -max -1 + list -type list -help\ + "tcl list as a value" + first -type indexexpression + last -type indexexpression + element -type string -optional 1 -multiple 1 + } "@doc -name Manpage: -url [manpage_tcl lreplace]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lremove + @cmd -name "builtin: lremove" -help\ + "Remove elements from a list by index + lremove returns a new list formed by simultaneously removing zero or + more elements of list at each of the indices given by an arbitrary + number of index arguments. The indices may be in any order and may be + repeated; the element at index will only be removed once. The index + values are interpreted the same as index values for the command + 'string index', supporting simple index arithmetic and indices relative + to the end of the list. 0 refers to the first element of the list, and + end refers to the last element of the list." + @values -min 1 -max -1 + list -type list -help\ + "tcl list as a value" + index -type indexexpression -multiple 1 -optional 1 + + @seealso -commands {list lappend lassign ledit lindex linsert llength lmap lpop lrange lrepeat lreplace lreverse lsearch lseq lset lsort} + } "@doc -name Manpage: -url [manpage_tcl lremove]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + punk::args::define { + @id -id ::lset + @cmd -name "builtin: lset" -help\ + "Change an element in a list. + The ${$B}lset${$N} command accepts a parameter, ${$I}varName${$NI}, which + it interprets as the name of a variable containint a Tcl list. It also + accepts zero or more ${$I}indices${$NI} into the list. The indices may + be presented either consecutively on the command line, or grouped in a + Tcl list and presented as a single argument. Finally, it accepts a new + value for an element of ${$I}varName${$NI}. + If no indices are presented, the command takes the form: + ${$B}lset${$N} ${$I}varName${$NI} ${$I}newValue${$NI} + or + ${$B}lset${$N} ${$I}varName${$NI} {} ${$I}newValue${$NI} + In this case, ${$I}newValue${$NI} replaces the old value of the variable + ${$I}varName${$N}. + + When presented with a single index, the ${$B}lset${$N} command treates the + contents of the ${$I}varName${$NI} variable as a Tcl list. It addresses + the ${$I}index${$NI}'th element in it (0 refers to the first element of the + list). When interpreting the list, ${$B}lset${$N} observes the same rules + concerning braces and quotes and backslashes as the Tcl command interpreter; + however; variable substitution and command substitution do not occur. + The command constructs a new list in which the designated element is replaced + with ${$I}newValue${$NI}. This new list is stored in the variable ${$I}varName${$NI}, + and is also the return value from the ${$B}lset${$N} command. + If ${$I}index${$NI} is negative or greater than the number of elements in + ${$I}$varName${$NI}, then an error occurs. + If ${$I}index${$NI} is equal to the number of elements in ${$I}$varName${$NI}, + then the given element is appended to the list. + The interpretation of each simple ${$I}index${$NI} value is the same as for the + command ${$B}string index${$N}, supporting simple index arithmetic and indices + relative to the end of the list. + If additional ${$I}index${$NI} arguments are supplied, then each argument is used + in turn to address an element within a sublist designated by the previous indexing + operation, allowing the script to alter elements in sublists (or append elements to + sublists). + The command, + ${$B}lset${$N} a 1 2 newValue + or + ${$B}lset${$N} a {1 2} newValue + replaces element 2 of sublist 1 with ${$I}newValue${$NI}. + The integer appearing in each ${$I}index${$NI} argument must be greater than or equal + to zero. The integer appearing in each ${$I}index${$NI} argument must be less than or + equal to the length of the corresponding list. In other wirds, the ${$B}lset${$N} command + can change the size of a list only by appending an element (setting the one after + the current end). If an index is outside the permitted range, an error is reported." + @form -form index + @leaders -min 1 -max -1 + listVar -type string -help\ + "Existing list variable name" + index -type indexexpression -multiple 1 + @values -min 1 -max 1 + newValue -type any - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::lappend - @cmd -name "builtin: lappend" -help\ - "Append list elements onto a variable. - " - @values -min 1 -max -1 - varName -type string -help\ - "variable name" - value -type any -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl lappend]"] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::ledit - @cmd -name "builtin: ledit" -help\ - "Replace elements of a list stored in variable - " - @values -min 3 -max -1 - listVar -type string -help\ - "Existing list variable name" - first -type indexexpression - last -type indexexpression - value -type any -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl ledit]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lindex - @cmd -name "builtin: lindex" -help\ - "Retrieve an element from a list - " - @values -min 1 -max -1 - list -type list -help\ - "tcl list as a value" - index -type indexexpression -multiple 1 -optional 1 -help\ - "When no index is supplied or a single index is supplied as an empty list, - the value of the entire list is simply returned. - - If a single index is supplied and is a list of indices - this list is used - as a sequence of nested indices. - The command, - lindex $a 1 2 3 - or - lindex $l {1 2 3} - is synonymous with - lindex [lindex [lindex $a 1] 2] 3 - - When presented with a single indes, the lindex command treats list as a Tcl list - and returns the index'th element from it (0 refers to the first element of the - list). In extracting the element, lindex observes the same rules concerning - braces and quotes and backslashes as the Tcl command interpreter; however, - variable substution and command substitution do not occur. If index is negative - or greater than or equal to the number of elements in 'list', then an empty - string is returned. The interpretation of each simple index value is the same - as for the command 'string index', supporting simple index arithmetic and - indices relative to the end of the list. - - If additional index arguments are supplied, then each argument is used in turn - to select an element from the previous indexing operation, allowing the script - to select elements from sublists." - } "@doc -name Manpage: -url [manpage_tcl lindex]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::list - @cmd -name "builtin: list" -help\ - "Create a list - - This command returns a list comprised of all the args, or an empty string - if no args are specified. Braces and backslashes get added as necessary, - so that the lindex command may be used on the result to re-extract the - original arguments, and also so that eval may be used to execute the - resulting list, with arg1 comprising the command's name and the other args - comprising its arguments. List produces slightly different results than - concat: concat removes one level of grouping before forming the list, - while list works directly from the original arguments." - @values -min 0 -max -1 - arg -type any -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl list]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lpop - @cmd -name "builtin: lpop" -help\ - "Get and remove an element in a list - " - @values -min 1 -max -1 - varName -type string -help\ - "Existing list variable name" - index -type indexexpression -default end -optional 1 -multiple 1 -help\ - "When presented with a single index, the lpop command addresses - the index'th element in it, removes it from the list and returns - the element. - If index is negative or greater or equal than the number of - elements in the list in the variable called varName, an error occurs. - If addition index arguments are supplied, then each argument is used - in turn to address an element within a sublist designated by the - previous indexing operation, allowing the script to remove elements - in sublists, similar to lindex and lset." - } "@doc -name Manpage: -url [manpage_tcl lpop]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lrange - @cmd -name "builtin: lrange" -help\ - "return one or more adjacent elements from a list. - The new list returned consists of elements first through last, inclusive. - The index values first and last are interpreted the same as index values - for the command 'string index', supporting simple index arithmetic and - indices relative to the end of the list. - e.g lrange {a b c} 0 end-1 - " - @values -min 3 -max 3 - list -type list -help\ - "tcl list as a value" - first -help\ - "index expression for first element" - last -help\ - "index expression for last element" - } "@doc -name Manpage: -url [manpage_tcl lrange]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + @form -form indexlist + @leaders -min 2 -max 2 + listVar -type string -help\ + "Existing list variable name" + indexList -type list -optional 1 -multiple 0 + @values -min 1 -max 1 + newValue -type any - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lremove - @cmd -name "builtin: lremove" -help\ - "Remove elements from a list by index - lremove returns a new list formed by simultaneously removing zero or - more elements of list at each of the indices given by an arbitrary - number of index arguments. The indices may be in any order and may be - repeated; the element at index will only be removed once. The index - values are interpreted the same as index values for the command - 'string index', supporting simple index arithmetic and indices relative - to the end of the list. 0 refers to the first element of the list, and - end refers to the last element of the list." - @values -min 1 -max -1 - list -type list -help\ - "tcl list as a value" - index -type indexexpression -multiple 1 -optional 1 - - @seealso -commands {list lappend lassign ledit lindex linsert llength lmap lpop lrange lrepeat lreplace lreverse lsearch lseq lset lsort} - } "@doc -name Manpage: -url [manpage_tcl lremove]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::lrange - @cmd -name "builtin: lrange" -help\ - "return one or more adjacent elements from a list. - The new list returned consists of elements first through last, inclusive. - The index values first and last are interpreted the same as index values - for the command 'string index', supporting simple index arithmetic and - indices relative to the end of the list. - e.g lrange {a b c} 0 end-1" - @values -min 3 -max 3 - list -type list -help\ - "tcl list as a value" - first -help\ - "index expression for first element" - last -help\ - "index expression for last element" - } "@doc -name Manpage: -url [manpage_tcl lrange]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } "@doc -name Manpage: -url [manpage_tcl lset]" + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + } ############################################################################################################################################################ @@ -974,8 +1792,27 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + namespace eval argdoc { + punk::args::define { + @id -id ::split + @cmd -name "builtin: split" -help\ + "Split a string into a proper Tcl list. + Returns a list created by splitting string at each character that is in + the ${$I}splitChars${$NI} argument. Each element of the result list will + consist of the characters from ${$I}string${$NI} that lie between instances + of the characters in ${$I}splitChars${$NI}. Empty list elements will be + generated if string contains adjacent characters in ${$I}splitChars${$NI}, + or if the first or last character of string is in ${$I}splitChars${$NI}. + If ${I}splitChars${$NI} is an empty string then each character of ${$I}string${$NI} + becomes a separate element of the result list. ${$I}splitChars${$NI} defaults + to the standard white-space characters." + @values -min 1 -max 2 + string -type string + splitChars -type string -optional 1 + } "@doc -name Manpage: -url [manpage_tcl split]" + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { @@ -1108,7 +1945,7 @@ tcl::namespace::eval punk::args::tclcore { end. The initial string is returned untouched, if first is greater than last, or if first is equal to or greater than the length of the inital string, or last is less than 0." - @values -min 3 -max 3 + @values -min 3 -max 4 string -type string first -type indexexpression last -type indexexpression @@ -1209,7 +2046,7 @@ tcl::namespace::eval punk::args::tclcore { 7-bit ascii range)" boolean\ " Any of the forms allowed - to Tcl_GetBoolean" + for Tcl_GetBoolean" control\ " Any Unicode control char" dict\ @@ -1229,14 +2066,14 @@ tcl::namespace::eval punk::args::tclcore { range." double\ " Any of the forms allowed - to Tcl_GetDoubleFromObj. + for Tcl_GetDoubleFromObj. ${$A_WARN}With optional surrounding${$A_RST} ${$A_WARN}whitespace.${$A_RST}" entier\ " Synonym for integer" false\ " Any of the forms allowed - to Tcl_GetBoolean where the + for Tcl_GetBoolean where the value is false" graph\ " Any Unicode printing char @@ -1279,7 +2116,7 @@ tcl::namespace::eval punk::args::tclcore { (U+feff) (=BOM)" true\ " Any of the forms allowed - to Tcl_GetBoolean where the + for Tcl_GetBoolean where the value is true" upper\ " Any upper case alphabet @@ -1314,8 +2151,8 @@ tcl::namespace::eval punk::args::tclcore { otherwise an empty string will return 1 on any class" -failindex -type variablename -help\ "If -failindex is specified, then if the function returns 0, - the index in the string where the class was no longer valid will be stored - in the variable named." + the index in the string where the class was no longer + valid will be stored in the variable named." @values -min 1 -max 1 string -type string -optional 0 }] "@doc -name Manpage: -url [manpage_tcl string]" @@ -1348,7 +2185,7 @@ tcl::namespace::eval punk::args::tclcore { obsolete {variable vdelete vinfo} }\ -choiceinfo { - add {subhelp "::trace add"} + add {{doctype punkargs} {subhelp ::trace add}} } } "@doc -name Manpage: -url [manpage_tcl trace]" @@ -1363,7 +2200,8 @@ tcl::namespace::eval punk::args::tclcore { "" {command execution variable} }\ -choiceinfo { - command {subhelp "::trace add command"} + command {{doctype punkargs}} + execution {{doctype punkargs}} } } "@doc -name Manpage: -url [manpage_tcl trace]" @@ -1542,10 +2380,13 @@ tcl::namespace::eval punk::args::tclcore { "Create and initialise a namespace variable. " @form -form "setvalues" -synopsis "variable ?name value...? ?name?" - @values -min 2 -max -1 - #todo + @values -min 0 -max -1 + #todo - some sort of striding for values that must occur in groups of length n + #here we have n=2 except for last which can be 1 + #review - how to handle? + #In this case - we don't want name_value to display - as this is only used for documenting a builtin - #For the case where an @argroups is used also for parsing - the help should display the synopsis form + #For the case where an @arggroups is used also for parsing - the help should display the synopsis form #and also the name of the var in which it is placed. # e.g # ?{name value}...? @@ -1570,50 +2411,98 @@ tcl::namespace::eval punk::args::tclcore { namespace eval argdoc { if {[catch {zlib::pkgconfig get zlibVersion} ZLIBVERSION]} { set ZLIBVERSION "(unknown)" + } - } - punk::args::define { - @id -id ::zlib - @cmd -name "builtin: ::zlib" -help\ - "zlib - compression and decompression operations - zlib version: ${$::punk::args::tclcore::argdoc::ZLIBVERSION}" - @leaders -min 1 -max 1 - subcommand -type string\ - -choicecolumns 2\ - -choicegroups { - compression {compress decompress deflate gunzip gzip inflate} - channel {push} - streaming {stream} - checksumming {adler32 crc32} - }\ - -choicelabels { - compress "zlib compress string ?level?" - decompress "zlib decompress string ?buffersize?" - deflate "zlib deflate string ?level?" - gunzip "zlib gunzip string ?-headerVar varName?" - gzip "zlib gzip string ?-level level? ?-header dict?" - inflate "zlib inflate string ?bufferSize?" - push "zlib push mode channel ?options ...?" - stream "zlib stream mode ?options?" - adler32 "zlib adler32 string ?initValue?" - crc32 "zlib crc32 string ?initValue?" - }\ - -choiceinfo { - adler32 {} + #zlib is an ensemble-*like* native command + #we can't use 'namespace ensemble configure' to query it + + #define subcommand documentation first + punk::args::define { + @dynamic + @id -id "::zlib adler32" + @cmd -name "builtin: ::zlib adler32" -help\ + "Compute a checksum of binary string ${$I}string${$NI} using the Adler32 + algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. + " + @values -min 1 -max 2 + string -type string + initValue -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + + punk::args::define { + @dynamic + @id -id "::zlib crc32" + @cmd -name "builtin: ::zlib crc32" -help\ + "Compute a checksum of binary string ${$I}string${$NI} using the CRC-32 + algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. + " + @values -min 1 -max 2 + string -type string + initValue -type string -optional 1 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + + punk::args::define { + @dynamic + @id -id "::zlib compress" + @cmd -name "builtin: ::zlib compress" -help\ + "Returns the zlib-format compressed binary data of the binary string in ${$I}string${$NI}. + If present, ${$I}level${$NI} gives the compression level to use (from 0, which is + uncompressed, to 9, maximally compressed)." + @values -min 1 -max 2 + string -type string + level -type integer -range {0 9} -optional 1 + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" + + + set CHOICES [list compress decompress deflate gunzip gzip inflate push stream adler32 crc32] + + #manual synopses for subcommands not yet defined + set CHOICELABELS { + compress "zlib compress string ?level?" + decompress "zlib decompress string ?buffersize?" + deflate "zlib deflate string ?level?" + gunzip "zlib gunzip string ?-headerVar varName?" + gzip "zlib gzip string ?-level level? ?-header dict?" + inflate "zlib inflate string ?bufferSize?" + push "zlib push mode channel ?options ...?" + stream "zlib stream mode ?options?" + adler32 "zlib adler32 string ?initValue?" + crc32 "zlib crc32 string ?initValue?" + } + set CHOICEINFO [dict create] + foreach sub $CHOICES { + #default for all + dict set CHOICEINFO $sub {{doctype native}} + } + foreach id [punk::args::get_ids "::zlib *"] { + if {[llength $id] == 2} { + lassign $id _ sub + dict set CHOICEINFO $sub {{doctype native} {doctype punkargs}} + #override manual synopsis entry + dict set CHOICELABELS $sub [punk::ns::synopsis "::zlib $sub"] } + } + + punk::args::define { + @id -id ::zlib + @cmd -name "builtin: ::zlib" -help\ + "zlib - compression and decompression operations + zlib version: ${$ZLIBVERSION}" + @leaders -min 1 -max 1 + subcommand -type string\ + -choicecolumns 2\ + -choicegroups { + compression {compress decompress deflate gunzip gzip inflate} + channel {push} + streaming {stream} + checksumming {adler32 crc32} + }\ + -choicelabels {${$CHOICELABELS}}\ + -choiceinfo {${$CHOICEINFO}} - } "@doc -name Manpage: -url [manpage_tcl zlib]" + } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]" - punk::args::define { - @id -id "::zlib adler32" - @cmd -name "builtin: ::zlib adler32" -help\ - "Compute a checksum of binary string ${$I}string${$NI} using the Adler32 - algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. - " - @values -min 1 -max 2 - string -type string - initValue -type string -optional 1 - } "@doc -name Manpage: -url [manpage_tcl zlib]" + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- diff --git a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm index aaa595ae..2d949ccf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm @@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates { namespace export * namespace eval class { variable PUNKARGS - #set argd [punk::args::get_dict { - # @id -id "::punk::cap::handlers::templates::class::api folders" - # -startdir -default "" - # @values -max 0 - #} $args] - lappend PUNKARGS [list { - @id -id "::punk::cap::handlers::templates::class::api folders" - -startdir -default "" - @values -max 0 - }] + #lappend PUNKARGS [list { + # @id -id "::punk::cap::handlers::templates::class::api folders" + # -startdir -default "" + # @values -max 0 + #}] oo::class create api { #return a dict keyed on folder with source pkg as value @@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates { set cname [string map {. _} $capname] set capabilityname $capname } + set class_ns [uplevel 1 [list namespace current]] + + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api folders" + @cmd -name "punk::cap::handlers::templates::class::api folders" + -startdir -default "" -help\ + "Defaults to CWD if not supplied" + @values -max 0 + }] method folders {args} { #puts "--folders $args" - set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] + set argd [punk::args::parse $args withid "[self class] folders"] set opts [dict get $argd opts] set opt_startdir [dict get $opts -startdir] @@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates { } return $folderdict } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" + @cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\ + "" + @opts -anyopts 1 + #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here + -startdir -default "" + @values -maxvalues -1 + }] method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" - @opts -anyopts 1 - #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here - -startdir -default "" - @values -maxvalues -1 - } $args] + + set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"] + set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { @@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates { my _get_itemdict {*}$arglist } + lappend ${class_ns}::PUNKARGS [list { + @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" + @cmd -name _get_itemdict + @opts -anyopts 0 + -startdir -default "" + -templatefolder_subdir -optional 0 + -command_get_items_from_base -optional 0 + -command_get_item_name -optional 0 + -not -default "" -multiple 1 + @values -maxvalues -1 + globsearches -default * -multiple 1 + }] + #shared algorithm for get_itemdict_* methods #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { - @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" - @cmd -name _get_itemdict - @opts -anyopts 0 - -startdir -default "" - -templatefolder_subdir -optional 0 - -command_get_items_from_base -optional 0 - -command_get_item_name -optional 0 - -not -default "" -multiple 1 - @values -maxvalues -1 - globsearches -default * -multiple 1 - } $args] + set argd [punk::args::parse $args withid "[self class] _get_itemdict"] + set opts [dict get $argd opts] set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results #puts stderr "=-=============>globsearches:$globsearches" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm index e278d99f..3a5f25b0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm @@ -44,8 +44,11 @@ tcl::namespace::eval punk::config { @values -min 0 -max 0 }] proc dir {args} { + #set be_quiet [dict exists $received -quiet] if {"-quiet" in $args} { - set be_quiet [dict exists $received -quiet] + set be_quiet 1 + } else { + set be_quiet 0 } set was_noisy 0 @@ -445,6 +448,7 @@ tcl::namespace::eval punk::config { "Get configuration values from a config. Accepts globs eg XDG*" @leaders -min 1 -max 1 + #todo - load more whichconfig choices? whichconfig -type string -choices {config startup-configuration running-configuration} @values -min 0 -max -1 globkey -type string -default * -optional 1 -multiple 1 @@ -526,18 +530,23 @@ tcl::namespace::eval punk::config { error "setting value not implemented" } - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::config::show - @cmd -name punk::config::get -help\ - "Display configuration values from a config. - Accepts globs eg XDG*" - @leaders -min 1 -max 1 - }\ - {${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ - "@values -min 0 -max -1"\ - {${[punk::args::resolved_def -types values ::punk::config::get]}}\ - ] + namespace eval argdoc { + set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}} + set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}} + + lappend PUNKARGS [list { + @dynamic + @id -id ::punk::config::show + @cmd -name punk::config::get -help\ + "Display configuration values from a config. + Accepts globs eg XDG*" + @leaders -min 1 -max 1 + }\ + {${$DYN_GET_LEADERS}}\ + "@values -min 0 -max -1"\ + {${$DYN_GET_VALUES}}\ + ] + } proc show {args} { #todo - tables for console set configrecords [punk::config::get {*}$args] @@ -568,7 +577,7 @@ tcl::namespace::eval punk::config { toconfig -help\ "running or startup or file name (not fully implemented)" } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::parse $args withdef $argdef] set fromconfig [dict get $argd values fromconfig] set toconfig [dict get $argd values toconfig] set fromconfig [string map {-config ""} $fromconfig] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm index adb47eff..7d1375d7 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/du-0.1.0.tm @@ -562,13 +562,13 @@ namespace eval punk::du { proc Get_attributes_from_iteminfo {args} { variable win_reparse_tags_by_int - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::Get_attributes_from_iteminfo -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" - } $args] + }] set opts [dict get $argd opts] set iteminfo [dict get $argd values iteminfo] set opt_debug [dict get $opts -debug] @@ -621,14 +621,14 @@ namespace eval punk::du { proc attributes_twapi {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::du::lib::attributes_twapi -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debugchannel -default stderr -help "channel to write debug output, or none to append to output" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" - } $args] + }] set opts [dict get $argd opts] set path [dict get $argd values path] set opt_detail [dict get $opts -detail] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm index ca222524..86126a5c 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm @@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib { } proc range_boundaries {start end chunksizes args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { -offset -default 0 - } $args] + }] lassign [dict values $argd] leaders opts remainingargs } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm index b6c6dd4a..92cab7e9 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm @@ -1105,7 +1105,7 @@ namespace eval punk::lib { } }] #puts stderr "$argspec" - set argd [punk::args::get_dict $argspec $args] + set argd [punk::args::parse $args withdef $argspec] set opts [dict get $argd opts] set dvar [dict get $argd values dictvar] @@ -1147,7 +1147,7 @@ namespace eval punk::lib { #package require punk ;#we need pipeline pattern matching features package require textblock - set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { @id -id ::punk::lib::showdict @cmd -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject @@ -1178,7 +1178,7 @@ namespace eval punk::lib { "dict or list value" patterns -default "*" -type string -multiple 1 -help\ "key or key glob pattern" - }] $args] + }]] #for punk::lib - we want to reduce pkg dependencies. # - so we won't even use the tcllib debug pkg here @@ -2870,7 +2870,7 @@ namespace eval punk::lib { proc list_as_lines {args} { #*** !doctools #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] - #[para]This simply joines the elements of the list with -joinchar + #[para]This simply joins the elements of the list with -joinchar #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. if {[set eop [lsearch $args --]] == [llength $args]-2} { @@ -2890,12 +2890,11 @@ namespace eval punk::lib { } proc list_as_lines2 {args} { #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? - lassign [tcl::dict::values [punk::args::get_dict { + lassign [tcl::dict::values [punk::args::parse $args withdef { -joinchar -default \n @values -min 1 -max 1 - } $args]] leaders opts values - puts "opts:$opts" - puts "values:$values" + }]] leaders opts values + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] } @@ -2932,10 +2931,10 @@ namespace eval punk::lib { #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc #we don't have to decide what is an opt vs a value #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) - lassign [tcl::dict::values [punk::args::get_dict { + lassign [tcl::dict::values [punk::args::parse $args withdef { @opts -any 1 -block -default {} - } $args]] leaderdict opts valuedict + }]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] } @@ -4198,10 +4197,10 @@ tcl::namespace::eval punk::lib::system { #get info about punk nestindex key ie type: list,dict,undetermined # pdict devel proc nestindex_info {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { -parent -default "" nestindex - } $args] + }] set opt_parent [dict get $argd opts -parent] if {$opt_parent eq ""} { set parent_type undetermined diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm new file mode 100644 index 00000000..5532ed33 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm @@ -0,0 +1,4237 @@ +# -*- 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::lib 0.1.2 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::lib 0 0.1.2] +#[copyright "2024"] +#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk library}] [comment {-- Description at end of page heading --}] +#[require punk::lib] +#[keywords module utility lib] +#[description] +#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. +#[para]The base set includes string and math functions but has no specific theme + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::lib +#[subsection Concepts] +#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. +#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::lib +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +tcl::namespace::eval punk::lib::ensemble { + #wiki.tcl-lang.org/page/ensemble+extend + # extend an ensemble-like routine with the routines in some namespace + proc extend {routine extension} { + if {![string match ::* $routine]} { + set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![string match ::* $extension]} { + set extension [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$extension + } + + if {![tcl::namespace::exists $extension]} { + error [list {no such namespace} $extension] + } + + set extension [tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] current]] + + tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] export *] + + while 1 { + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] + if {[tcl::namespace::which $renamed] eq {}} break + } + + rename $routine $renamed + + tcl::namespace::eval $extension [ + list namespace ensemble create -command $routine -unknown [ + list apply {{renamed ensemble routine args} { + list $renamed $routine + }} $renamed + ] + ] + + return $routine + } +} + +# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated +tcl::namespace::eval punk::lib::check { + proc has_tclbug_script_var {} { + + set script {set j [list spud] ; list} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + return true + } else { + return false + } + } + proc has_tclbug_lsearch_strideallinline {} { + #bug only occurs with single -index value combined with -stride -all -inline -subindices + #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d + if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { + #we aren't looking for an error result - error most likely indicates tcl too old to support -stride + return 0 + } + return [expr {$result ne "a2"}] + } + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { + #ensemble calls within safe interp not compiled + namespace eval [namespace current]::testcompile { + proc ensembletest {} {string index a 0} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr has_bug + } + return $has_bug + } +} + +tcl::namespace::eval punk::lib::compat { + #*** !doctools + #[subsection {Namespace punk::lib::compat}] + #[para] compatibility functions for features that may not be available in earlier Tcl versions + #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. + #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. + + #*** !doctools + #[list_begin definitions] + + + + + if {"::lremove" ne [info commands ::lremove]} { + #puts stderr "Warning - no built-in lremove" + interp alias {} lremove {} ::punk::lib::compat::lremove + } + proc lremove {list args} { + #*** !doctools + #[call [fun lremove] [arg list] [opt {index ...}]] + #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove + + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 + + if {![info exists ::auto_index(readFile)]} { + if {[info commands ::readFile] eq ""} { + proc ::readFile {filename {mode text}} { + #readFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + + # Read the file + set f [open $filename [dict get {text r binary rb} $mode]] + try { + return [read $f] + } finally { + close $f + } + } + } + } + if {![info exists ::auto_index(writeFile)]} { + if {[info commands ::writeFile] eq ""} { + proc ::writeFile {args} { + #writeFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + switch [llength $args] { + 2 { + lassign $args filename data + set mode text + } + 3 { + lassign $args filename mode data + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + } + default { + set COMMAND [lindex [info level 0] 0] + return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" + } + } + + # Write the File + set f [open $filename [dict get {text w binary wb} $mode]] + try { + puts -nonewline $f $data + } finally { + close $f + } + } + } + } + + if {"::lpop" ne [info commands ::lpop]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lpop + } + proc lpop {lvar args} { + #*** !doctools + #[call [fun lpop] [arg listvar] [opt {index}]] + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + + + #slight isolation - varnames don't leak - but calling context vars can be affected + proc lmaptcl2 {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result [apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + if {"::lmap" ne [info commands ::lmap]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lmap {} ::punk::lib::compat::lmaptcl + } + #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway + proc lmaptcl {varnames list script} { + set result [list] + set varlist [list] + foreach varname $varnames { + upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc + lappend varlist var_$varname + } + foreach $varlist $list { + lappend result [uplevel 1 $script] + } + return $result + } + + #tcl8.7/9 compatibility for 8.6 + if {[info commands ::tcl::string::insert] eq ""} { + #https://wiki.tcl-lang.org/page/string+insert + # Pure Tcl implementation of [string insert] command. + proc ::tcl::string::insert {string index insertString} { + # Convert end-relative and TIP 176 indexes to simple integers. + if {[regexp -expanded { + ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace + |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace + (?:([+-]) # op, omitted when index is "end" + ([+-]?\d+))? # n, omitted when index is "end" + [\t\n\v\f\r ]*$ # optional whitespace (unless "end") + } $index _ m op n]} { + # Convert first index to an integer. + switch $m { + end {set index [string length $string]} + default {scan $m %d index} + } + + # Add or subtract second index, if provided. + switch $op { + + {set index [expr {$index + $n}]} + - {set index [expr {$index - $n}]} + } + } elseif {![string is integer -strict $index]} { + # Reject invalid indexes. + return -code error "bad index \"$index\": must be\ + integer?\[+-\]integer? or end?\[+-\]integer?" + } + + # Concatenate the pre-insert, insertion, and post-insert strings. + string cat [string range $string 0 [expr {$index - 1}]] $insertString\ + [string range $string $index end] + } + + # Bind [string insert] to [::tcl::string::insert]. + tcl::namespace::ensemble configure string -map [tcl::dict::replace\ + [tcl::namespace::ensemble configure string -map]\ + insert ::tcl::string::insert] + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::lib { + variable PUNKARGS + tcl::namespace::export * + variable has_struct_list + set has_struct_list [expr {![catch {package require struct::list}]}] + variable has_struct_set + set has_struct_set [expr {![catch {package require struct::set}]}] + variable has_punk_ansi + set has_punk_ansi [expr {![catch {package require punk::ansi}]}] + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + + #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) + proc aliases {{glob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + set ns_mapped [string map {:: \uFFFF} $ns] + #puts stderr "aliases ns: $ns_mapped" + set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: + if {![string length [lindex $segments end]]} { + #special case for :: only include leading segment rather thatn {} {} + set segments [lrange $segments 0 end-1] + } + set segcount [llength $segments] ;#only match number of segments matching current ns + + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + + set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" + if {($acount - 1) == $segcount} { + if {[lrange $asegs 0 end-1] eq $segments} { + if {[string match $glob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + + return $matched + } + + proc alias {{aliasorglob ""} args} { + set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + if {[llength $args]} { + if {$aliasorglob in [interp aliases ""]} { + set existing [interp alias "" $aliasorglob] + puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" + } + if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { + #use empty string/whitespace as intention to delete alias + return [interp alias "" $aliasorglob ""] + } + return [interp alias "" $aliasorglob "" {*}$args] + } else { + if {![string length $aliasorglob]} { + set aliaslist [punk::lib::aliases] + puts -nonewline stderr $aliaslist + return + } + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias + set target [interp alias "" $aliasorglob] + if {[llength $target]} { + return $target + } + + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { + set aliaslist [punk::lib::aliases $aliasorglob] + puts -nonewline stderr $aliaslist + return + } + return [list] + } + } + + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + + # -- --- + #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists + #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 + #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows + # Review and retest as new versions come out. + # -- --- + proc list_multi_append1 {lvar1 lvar2} { + #clear winner in 2024 + upvar $lvar1 l1 $lvar2 l2 + lappend l1 {*}$l2 + return $l1 + } + proc list_multi_append2 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [list {*}$l1 {*}$l2] + } + proc list_multi_append3 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] + } + #testing e.g + #set l1_reset {a b c} + #set l2 {a b c d e f g} + #set l1 $l1_reset + #time {list_multi_append1 l1 l2} 1000 + #set l1 $l1_reset + #time {list_multi_append2 l1 l2} 1000 + # -- --- + + + proc lswap {lvar a z} { + upvar $lvar l + if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} { + #lindex_resolve_basic returns only -1 if out of range + #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred + #(e.g using: lswap mylist end-2 end on a two element list) + + #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report + #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) + set a_index [lindex_resolve $l $a] + set a_msg "" + switch -- $a_index { + -2 { + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + } + -3 { + set a_msg "1st supplied index $a is below the lower bound for the list (0)" + } + } + set z_index [lindex_resolve $l $z] + set z_msg "" + switch -- $z_index { + -2 { + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } + -3 { + set z_msg "2nd supplied index $z is below the lower bound for the list (0)" + } + } + set errmsg "lswap cannot swap indices $a and $z" + if {$a_msg ne ""} { + append errmsg \n $a_msg + } + if {$z_msg ne ""} { + append errmsg \n $z_msg + } + error $errmsg + } + set item2 [lindex $l $z] + lset l $z [lindex $l $a] + lset l $a $item2 + return $l + } + #proc lswap2 {lvar a z} { + # upvar $lvar l + # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] + #} + + proc lswap2 {lvar a z} { + upvar $lvar l + #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] + } + + #an experimental test of swapping vars without intermediate variables + #It's an interesting idea - but probably of little to no practical use + # - the swap_intvars3 version using intermediate var is faster in Tcl + # - This is probably unsurprising - as it's simpler code. + # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. + #proc swap_intvars {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] + #} + #proc swap_intvars2 {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {$_x ^ $_y}] + # set _y [expr {$_x ^ $_y}] + # set _x [expr {$_x ^ $_y}] + #} + #proc swap_intvars3 {swapv1 swapv2} { + # #using intermediate variable + # upvar $swapv1 _x $swapv2 _y + # set z $_x + # set _x $_y + # set _y $z + #} + + #*** !doctools + #[subsection {Namespace punk::lib}] + #[para] Core API functions for punk::lib + #[list_begin definitions] + + 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 + #support minimal set from to + proc range {from to} { + lseq $from $to + } + } else { + #lseq accepts basic expressions e.g 4-2 for both arguments + #e.g we can do lseq 0 [llength $list]-1 + #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. + proc range {from to} { + set to [offset_expr $to] + set from [offset_expr $from] + if {$to > $from} { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + #slower methods. + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from] + #} + #return $L + } elseif {$from > $to} { + set count [expr {$from - $to} + 1] + #1) + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from -1];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from -1] + #} + #return $L + } else { + return [list $from] + } + } + } + + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + return $zip_l + } + #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible + if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { + #-stride either not available - or has bug preventing use of main algorithm below + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + } else { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + + + namespace import ::punk::args::lib::tstr + + + + proc invoke command { + #*** !doctools + #[call [fun invoke] [arg command]] + #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode + #[example { + # set script { + # puts stdout {hello on stdout} + # puts stderr {hello on stderr} + # exit 42 + # } + # invoke [list tclsh <<$script] + #}] + + #see https://wiki.tcl-lang.org/page/open + lassign [chan pipe] chanout chanin + lappend command 2>@$chanin + set fh [open |$command] + set stdout [read $fh] + close $chanin + set stderr [read $chanout] + close $chanout + if {[catch {close $fh} cres e]} { + dict with e {} + lassign [set -errorcode] sysmsg pid exit + if {$sysmsg eq {NONE}} { + #output to stderr caused [close] to fail. Do nothing + } elseif {$sysmsg eq {CHILDSTATUS}} { + return [list $stdout $stderr $exit] + } else { + return -options $e $stderr + } + } + return [list $stdout $stderr 0] + } + + proc pdict {args} { + package require punk::args + variable has_punk_ansi + if {!$has_punk_ansi} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } + set argspec [string map [list %sep% $sep] { + @id -id ::punk::lib::pdict + @cmd -name pdict -help\ + "Print dict keys,values to channel + The pdict function operates on variable names - passing the value to the showdict function which operates on values + (see also showdict)" + + @opts -any 1 + + #default separator to provide similarity to tcl's parray function + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} + -channel -default stdout -help\ + "existing channel - or 'none' to return as string" + + @values -min 1 -max -1 + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + Segments are classified into list,dict and string operations. + Leading % indicates a string operation - e.g %# gives string length + A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 + A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' + The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. + e.g1 pdict env */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segement in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + } + }] + #puts stderr "$argspec" + set argd [punk::args::parse $args withdef $argspec] + + set opts [dict get $argd opts] + set dvar [dict get $argd values dictvar] + set patterns [dict get $argd values patterns] + set isarray [uplevel 1 [list array exists $dvar]] + if {$isarray} { + set dvalue [uplevel 1 [list array get $dvar]] + if {![dict exists $opts -keytemplates]} { + set arrdisplay [string map [list %dvar% $dvar] {${[if {[lindex $key 1] eq "query"} {val "%dvar% [lindex $key 0]"} {val "%dvar%($key)"}]}}] + dict set opts -keytemplates [list $arrdisplay] + } + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } + showdict {*}$opts $dvalue {*}$patterns + } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality + proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) + #set sep " [a+ Web-seagreen]=[a] " + variable has_punk_ansi + if {!$has_punk_ansi} { + set RST "" + set sep " = " + set sep_mismatch " mismatch " + } else { + set RST [punk::ansi::a] + set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " + } + package require punk::pipe + #package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + @id -id ::punk::lib::showdict + @cmd -name punk::lib::showdict -help "display dictionary keys and values" + #todo - table tableobject + -return -default "tailtohead" -choices {tailtohead sidebyside} + -channel -default none + -trimright -default 1 -type boolean -help\ + "Trim whitespace off rhs of each line. + This can help prevent a single long line that wraps in terminal from making + every line wrap due to long rhs padding." + -separator -default {%sep%} -help\ + "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help\ + "Separator to use when patterns mismatch" + -roottype -default "dict" -help\ + "list,dict,string" + -ansibase_keys -default "" -help\ + "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} + -ansibase_values -default "" + -keytemplates -default {\$\{$key\}} -type list -help\ + "list of templates for keys at each level" + -keysorttype -default "none" -choices {none dictionary ascii integer real} + -keysortdirection -default increasing -choices {increasing decreasing} + -debug -default 0 -type boolean -help\ + "When enabled, produces some rudimentary debug output on stderr" + @values -min 1 -max -1 + dictvalue -type list -help\ + "dict or list value" + patterns -default "*" -type string -multiple 1 -help\ + "key or key glob pattern" + }]] + + #for punk::lib - we want to reduce pkg dependencies. + # - so we won't even use the tcllib debug pkg here + set opt_debug [dict get $argd opts -debug] + if {$opt_debug} { + if {[info body debug::showdict] eq ""} { + proc ::punk::lib::debug::showdict {args} { + catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} + } + } + } else { + if {[info body debug::showdict] ne ""} { + proc ::punk::lib::debug::showdict {args} {} + } + } + + set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] + set opt_keysorttype [dict get $argd opts -keysorttype] + set opt_keysortdirection [dict get $argd opts -keysortdirection] + set opt_trimright [dict get $argd opts -trimright] + set opt_keytemplates [dict get $argd opts -keytemplates] + debug::showdict "keytemplates ---> $opt_keytemplates <---" + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] + set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] + + set dval [dict get $argd values dictvalue] + set patterns [dict get $argd values patterns] + + set result "" + + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set pattern_this_structure [dict create] + + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + + set filtered_keys [list] + if {$opt_roottype in {dict list string}} { + #puts "getting keys for roottype:$opt_roottype" + if {[llength $dval]} { + set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$} + set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + foreach pattern_nest $patterns { + set keyset [list] + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + if {[string index $p 0] eq "!"} { + set get_not 1 + set p [string range $p 1 end] + } else { + set get_not 0 + } + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string + } + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + #todo get_not !# is test for listiness (see punk) + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + #puts "showdict ---->@*<----" + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {$get_not} { + if {[dict exists $dval $k]} { + set keys [dict keys [dict remove $dval $k]] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + lappend keyset {*}[dict keys $dval] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + } + } else { + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + } + dict set pattern_this_structure $p dict + } + @k@* - @K@* { + #TODO get_not + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + #TODO get_not + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string + lappend keyset $p + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + if {$get_not} { + set keys [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $keys $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset $p + lappend keyset_structure list + } + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high + #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds + if {${lower_resolve} == -2} { + ##x + #lower bound is above upper list range + #match with decreasing indices is still possible + set lower [expr {[llength $dval]-1}] ;#set to max + } elseif {$lower_resolve == -3} { + ##x + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve $dval $b] + if {$upper == -3} { + ##x + #upper bound is below list range - + if {$lower_resolve >=-2} { + ##x + set upper 0 + } else { + continue + } + } elseif {$upper == -2} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + if {$get_not} { + set fullrange [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $fullrange {*}$keys] + if {$lower > $upper} { + set keys [lreverse $keys] + } + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + if {$get_not} { + lappend keyset [list !@$p query] + } else { + lappend keyset [list @$p query] + } + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + if {$get_not} { + set keys [dict keys [dict remove $dval {*}$keys]] + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + } + } + } + } + + # -- --- --- --- + #check next pattern-segment for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $segments 1] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + #ignore the NOT operator for purposes of query-type detection + if {[string index $pnext 0] eq "!"} { + set pnext [string range $pnext 1 end] + } + # single type in segment e.g /@@something/ + switch -exact $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + } + } + } + } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + if {$opt_keysorttype ne "none"} { + set int_keyset 1 + foreach k $keyset { + if {![string is integer -strict $k]} { + set int_keyset 0 + break + } + } + if {$int_keyset} { + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] + } else { + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] + } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] + } + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + + lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure + + #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" + } + } + #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" + } else { + puts stdout "unrecognised roottype: $opt_roottype" + return $dval + } + + if {[llength $filtered_keys]} { + #both keys and values could have newline characters. + #simple use of 'format' won't cut it for more complex dict keys/values + #use block::width or our columns won't align in some cases + switch -- $opt_return { + "tailtohead" { + #last line of key is side by side (possibly with separator) with first line of value + #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values + #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt {${$key}} + } + #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + set last_hidekey 0 + foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" + set hidekey 0 + set pattern_nest [lindex $pattern_key_index $kidx] + set pattern_nest_list [split $pattern_nest /] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" + + set is_match 1 ;#whether to display the normal separator or bad-match separator + switch -- $this_type { + dict { + #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + % thisval.= $qry= $dval + } else { + set thisval [tcl::dict::get $dval $key] + } + + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" + set is_match 0 + } + } + } + list { + if {[string is integer -strict $key]} { + set thisval [lindex $dval $key] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + % thisval.= $qry= $dval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + #if {![llength $nextpatterns]} { + # set nextpatterns * + #} + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + set is_match 0 + } + } + } + string { + set hidekey 1 + if {$key eq "%string"} { + set hidekey 1 + set thisval $dval + } elseif {$key eq "%ansiview"} { + set thisval [ansistring VIEW -lf 1 $dval] + } elseif {$key eq "%ansiviewstyle"} { + set thisval [ansistring VIEWSTYLE -lf 1 $dval] + } elseif {[string match *lpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] + } elseif {[string match *rpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + set thisval $dval + if {[string index $key 0] ne "%"} { + set key %$key + } + % thisval.= $key= $thisval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + #set nextopts [dict get $argd opts] + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + if {[llength $nextpatterns]} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } + } + if {$this_type eq "string" && $hidekey} { + lassign [textblock::size $thisval] _vw vwidth _vh vheight + #set blanks_above [string repeat \n [expr {$kheight -1}]] + set vblock $opt_ansibase_values$thisval$RST + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" + } else { + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + + set totalheight [expr {$kheight + $vheight -1}] + set blanks_above [string repeat \n [expr {$kheight -1}]] + set blanks_below [string repeat \n [expr {$vheight -1}]] + + if {$is_match} { + set use_sep $opt_sep + } else { + set use_sep $opt_mismatch_sep + } + + + set sepwidth [textblock::width $use_sep] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] + set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] + set vblock $blanks_above$opt_ansibase_values$thisval$RST + #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } + append result [textblock::join_basic -- $kblock $sblock $vblock] \n + } + set last_hidekey $hidekey + incr kidx + } + } + "sidebyside" { + # TODO - fix + #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. + #use ansibase_key etc to make the output more comprehensible in that situation. + #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] + foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST + #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n + #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n + } + } + } + } + if {$opt_trimright} { + set result [::join [lines_as_list -line trimright $result] \n] + } + if {[string last \n $result] == [string length $result]-1} { + set result [string range $result 0 end-1] + } + #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) + set chan [dict get $argd opts -channel] + switch -- $chan { + stderr - stdout { + puts $chan $result + } + none { + return $result + } + default { + #review - check member of chan names? + #just try outputting to the supplied channel for now + puts $chan $result + } + } + } + + proc is_list_all_in_list {small large} { + set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] + return [struct::list equal [lsort $small] $small_in_large] + } + if {!$has_struct_list || !$has_struct_set} { + set body { + package require struct::list + package require struct::set + } + append body [info body is_list_all_in_list] + proc is_list_all_in_list {small large} $body + } + + proc is_list_all_ni_list {a b} { + set i [struct::set intersect $a $b] + return [expr {[llength $i] == 0}] + } + if {!$has_struct_set} { + set body { + package require struct::list + } + append body [info body is_list_all_ni_list] + proc is_list_all_ni_list {a b} $body + } + + #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist + #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, + # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) + proc ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + proc ldiff2 {fromlist removeitems} { + set doomed [list] + foreach item $removeitems { + lappend doomed {*}[lsearch -all -exact $fromlist $item] + } + lremove $fromlist {*}$doomed + } + + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) + #also struct::set difference with critcl is faster + proc setdiff {A B} { + if {[llength $A] == 0} {return {}} + set d [dict create] + foreach x $A {dict set d $x {}} + foreach x $B {dict unset d $x} + return [dict keys $d] + } + #bulk dict remove is slower than a foreach with dict unset + #proc setdiff2 {fromlist removeitems} { + # #if {[llength $fromlist] == 0} {return {}} + # set d [dict create] + # foreach x $fromlist { + # dict set d $x {} + # } + # return [dict keys [dict remove $d {*}$removeitems]] + #} + #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) + proc setdiff_unordered {A B} { + if {[llength $A] == 0} {return {}} + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] + } + + #default/fallback implementation + proc lunique_unordered {list} { + lunique $list + } + if {$has_struct_set} { + if {[struct::set equal [struct::set union {a a} {}] {a}]} { + proc lunique_unordered {list} { + struct::set union $list {} + } + } else { + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add + } + } + + + #order-preserving + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + proc lunique2 {list} { + set doomed [list] + #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) + for {set i 0} {$i < [llength $list]} {} { + set item [lindex $list $i] + lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] + while {[incr i] in $doomed} {} + } + lremove $list {*}$doomed + } + #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env + proc lmapflat_closure {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + # -- --- --- + #capture - use uplevel 1 or namespace eval depending on context + set capture [uplevel 1 { + apply { varnames { + set capturevars [tcl::dict::create] + set capturearrs [tcl::dict::create] + foreach fullv $varnames { + set v [tcl::namespace::tail $fullv] + upvar 1 $v var + if {[info exists var]} { + if {(![array exists var])} { + tcl::dict::set capturevars $v $var + } else { + tcl::dict::set capturearrs capturedarray_$v [array get var] + } + } else { + #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set + } + } + return [tcl::dict::create vars $capturevars arrs $capturearrs] + } } [info vars] + } ] + # -- --- --- + set cvars [tcl::dict::get $capture vars] + set carrs [tcl::dict::get $capture arrs] + set apply_script "" + foreach arrayalias [tcl::dict::keys $carrs] { + set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { + array set %realname% [set %arrayalias%][unset %arrayalias%] + }] + } + + append apply_script [string map [list %script% $script] { + #foreach arrayalias [info vars capturedarray_*] { + # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + # array set $realname [set $arrayalias][unset arrayalias] + #} + #return [eval %script%] + %script% + }] + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ + $apply_script\ + ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] + } + return $result + } + #link version - can write to vars in calling context - but keeps varnames themselves isolated + #performance much better than capture version - but still a big price to pay for the isolation + proc lmapflat_link {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + #proc lmapflat {varnames list script} { + # concat {*}[uplevel 1 [list lmap $varnames $list $script]] + #} + #lmap can accept multiple var list pairs + proc lmapflat {args} { + concat {*}[uplevel 1 [list lmap {*}$args]] + } + proc lmapflat2 {args} { + concat {*}[uplevel 1 lmap {*}$args] + } + + #proc dict_getdef {dictValue args} { + # if {[llength $args] < 1} { + # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} + # } + # set keys [lrange $args -1 end-1] + # if {[tcl::dict::exists $dictValue {*}$keys]} { + # return [tcl::dict::get $dictValue {*}$keys] + # } else { + # return [lindex $args end] + # } + #} + 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::lib::dict_getdef "" ::tcl::dict::getdef + } + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side + proc lindex_resolve {list index} { + #*** !doctools + #[call [fun lindex_resolve] [arg list] [arg index]] + #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list + #[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl. + #[para]This means the proc may be called with something like $x+2 end-$y etc + #[para]Sometimes the actual integer index is desired. + #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. + #[para]lindex_resolve will parse the index expression and return: + #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) + #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) + #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list + #[para]Otherwise it will return an integer corresponding to the position in the list. + #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. + #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable + #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 + + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr + #if {![llength $list]} { + # #review + # return ??? + #} + set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + if {$index < 0} { + return -3 + } elseif {$index >= [llength $list]} { + return -2 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$op eq "+" && $offset != 0} { + return -2 + } + } else { + #index is 'end' + set index [expr {[llength $list]-1}] + if {$index < 0} { + #special case - 'end' with empty list - treat end like a positive number out of bounds + return -2 + } else { + return $index + } + } + if {$offset == 0} { + set index [expr {[llength $list]-1}] + if {$index < 0} { + return -2 ;#special case as above + } else { + return $index + } + } else { + #by now, if op = + then offset = 0 so we only need to handle the minus case + set index [expr {([llength $list]-1) - $offset}] + } + if {$index < 0} { + return -3 + } else { + return $index + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < 0} { + return -3 + } elseif {$index >= [llength $list]} { + return -2 + } + return $index + } + } + } + proc lindex_resolve_basic {list index} { + #*** !doctools + #[call [fun lindex_resolve_basic] [arg list] [arg index]] + #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) + #[para] returns -1 for out of range at either end, or a valid integer index + #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound + #[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command + #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 + #[para] For pure integer indices the performance should be equivalent + + #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ + # - which + #for {set i 0} {$i < [llength $list]} {incr i} { + # lappend indices $i + #} + set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + #avoid even the lseq overhead when the index is simple + if {$index < 0 || ($index >= [llength $list])} { + #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. + return -1 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } + if {[llength $list]} { + set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + } else { + set indices [list] + } + set idx [lindex $indices $index] + if {$idx eq ""} { + #we have no way to determine if out of bounds is at lower vs upper end + return -1 + } else { + return $idx + } + } + proc lindex_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [tcl::dict::create value [lindex $resultlist 0]] + } + } + + + proc K {x y} {return $x} + #*** !doctools + #[call [fun K] [arg x] [arg y]] + #[para]The K-combinator function - returns the first argument, x and discards y + #[para]see [uri https://wiki.tcl-lang.org/page/K] + #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + + + proc is_utf8_multibyteprefix {bytes} { + #*** !doctools + #[call [fun is_utf8_multibyteprefix] [arg str]] + #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character + #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint + #[para] Will return false for an already complete utf-8 codepoint + #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument + #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes + #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] + regexp {(?x) + ^ + (?: + [\xC0-\xDF] | #possible prefix for two-byte codepoint + [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for + ) + $ + } $bytes + } + + proc is_utf8_first {str} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + } $str + } + proc is_utf8_single {1234bytes} { + #*** !doctools + #[call [fun is_utf8_single] [arg 1234bytes]] + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + $ + } $1234bytes + } + proc get_utf8_leading {rawbytes} { + #*** !doctools + #[call [fun get_utf8_leading] [arg rawbytes]] + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint + #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. + #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. + #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics + #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned + #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes + if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $rawbytes completeChars]} { + return $completeChars + } + return "" + } + proc hex2dec {args} { + #*** !doctools + #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] + #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values + #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 + #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. + #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 + #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 + + set list_largeHex [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" + } + set opts [tcl::dict::create\ + -validate 1\ + -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $opts] + foreach {k v} $argopts { + tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v + } + # -- --- --- --- + set opt_validate [tcl::dict::get $opts -validate] + set opt_empty [tcl::dict::get $opts -empty_as_hex] + # -- --- --- --- + + set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] + if {$opt_validate} { + #Note appended F so that we accept list of empty strings as per the documentation + if {![string is xdigit -strict [join $list_largeHex ""]F ]} { + error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" + } + } + if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { + #mapping empty string to a value destroys any advantage of -scanonly + #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] + if {[lsearch $list_largeHex ""] >=0} { + error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" + } + } else { + set opt_empty [string trim [string map {_ ""} $opt_empty]] + if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] + set nonempty_head [lrange $list_largeHex 0 $first_empty-1] + set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] + } + + proc dec2hex {args} { + #*** !doctools + #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] + #[para]Convert a list of decimal integers to a list of hex values + #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. + #[para] -case upper|lower determines the case of the hex letters in the output + set list_decimals [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" + } + set defaults [tcl::dict::create\ + -width 1\ + -case upper\ + -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $defaults] + set fullopts [tcl::dict::create] + foreach {k v} $argopts { + tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v + } + set opts [tcl::dict::merge $defaults $fullopts] + # -- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_case [tcl::dict::get $opts -case] + set opt_empty [tcl::dict::get $opts -empty_as_decimal] + # -- --- --- --- + + + set resultlist [list] + switch -- [string tolower $opt_case] { + upper { + set spec X + } + lower { + set spec x + } + default { + error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" + } + } + set fmt "%${opt_width}.${opt_width}ll${spec}" + + set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] + if {![string is digit -strict [string map {_ ""} $opt_empty]]} { + if {[lsearch $list_decimals ""] >=0} { + error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" + } + } else { + set opt_empty [string map {_ ""} $opt_empty] + if {[set first_empty [lsearch $list_decimals ""]] >= 0} { + set nonempty_head [lrange $list_decimals 0 $first_empty-1] + set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] + } + + proc log2 x "expr {log(\$x)/[expr log(2)]}" + #*** !doctools + #[call [fun log2] [arg x]] + #[para]log base2 of x + #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time + #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) + + proc logbase {b x} { + #*** !doctools + #[call [fun logbase] [arg b] [arg x]] + #[para]log base b of x + #[para]This function uses expr's natural log and the change of base division. + #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 + expr {log($x)/log($b)} + } + proc factors {x} { + #*** !doctools + #[call [fun factors] [arg x]] + #[para]Return a sorted list of the positive factors of x where x > 0 + #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* + #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors + #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + #[para]Comparisons were done with some numbers below 17 digits long + #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers + #but has the disadvantage of being slower for 'small' numbers and using more memory. + #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x + #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + #[para] In other mathematical contexts zero may be considered not to divide anything. + set factors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {($x % $j) == 0} { + lappend factors $j [expr {$x / $j}] + } + incr j + } + lappend factors $x + return [lsort -unique -integer $factors] + } + proc oddFactors {x} { + #*** !doctools + #[call [fun oddFactors] [arg x]] + #[para]Return a list of odd integer factors of x, sorted in ascending order + set j 2 + set max [expr {sqrt($x)}] + set factors [list 1] + while {$j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2} { + if {$other ni $factors} { + lappend factors $other + } + } + if {$j % 2} { + if {$j ni $factors} { + lappend factors $j + } + } + } + incr j + } + return [lsort -integer -increasing $factors] + } + proc greatestFactorBelow {x} { + #*** !doctools + #[call [fun greatestFactorBelow] [arg x]] + #[para]Return the largest factor of x excluding itself + #[para]factor functions can be useful for console layout calculations + #[para]See Tcllib math::numtheory for more extensive implementations + if {$x % 2 == 0 || $x == 0} { + return [expr {$x / 2}] + } + set j 3 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {$x % $j == 0} { + return [expr {$x / $j}] + } + incr j 2 + } + return 1 + } + proc greatestOddFactorBelow {x} { + #*** !doctools + #[call [fun greatestOddFactorBelow] [arg x]] + #[para]Return the largest odd integer factor of x excluding x itself + if {$x %2 == 0} { + return [greatestOddFactor $x] + } + set j 3 + #dumb brute force - time taken to compute is wildly variable on big numbers + #todo - use a (memoized?) generator of primes to reduce the search space + #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. + set god 1 + set max [expr {sqrt($x)}] + while { $j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2 == 0} { + set god $j + } else { + set god [expr {$x / $j}] + #lowest j - so other side must be highest + break + } + } + incr j 2 + } + return $god + } + proc greatestOddFactor {x} { + #*** !doctools + #[call [fun greatestOddFactor] [arg x]] + #[para]Return the largest odd integer factor of x + #[para]For an odd value of x - this will always return x + if {$x % 2 != 0 || $x == 0} { + return $x + } + set r [expr {$x / 2}] + while {$r % 2 == 0} { + set r [expr {$r / 2}] + } + return $r + } + proc gcd {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the greatest common divisor of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para]Graphical use: + #[para]An a by b rectangle can be covered with square tiles of side-length c, + #[para]only if c is a common divisor of a and b + + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m + } + proc lcm {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the lowest common multiple of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para] + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] + } + proc commonDivisors {x y} { + #*** !doctools + #[call [fun commonDivisors] [arg x] [arg y]] + #[para]Return a list of all the common factors of x and y + #[para](equivalent to factors of their gcd) + return [factors [gcd $x $y]] + } + + #experimental only - there are better/faster ways + proc sieve n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + tcl::dict::for {next -} $nums break + } + return [concat $primes [tcl::dict::keys $nums]] + } + proc sieve2 n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + #dict for {next -} $nums break + set next [lindex $nums 0] + } + return [concat $primes [tcl::dict::keys $nums]] + } + + proc hasglobs {str} { + #*** !doctools + #[call [fun hasglobs] [arg str]] + #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] + #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. + regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving + } + + proc trimzero {number} { + #*** !doctools + #[call [fun trimzero] [arg number]] + #[para]Return number with left-hand-side zeros trimmed off - unless all zero + #[para]If number is all zero - a single 0 is returned + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + proc substring_count {str substring} { + #*** !doctools + #[call [fun substring_count] [arg str] [arg substring]] + #[para]Search str and return number of occurrences of substring + + #faster than lsearch on split for str of a few K + if {$substring eq ""} {return 0} + set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] + return [expr {$occurrences / [string length $substring]}] + } + + proc dict_merge_ordered {defaults main} { + #*** !doctools + #[call [fun dict_merge_ordered] [arg defaults] [arg main]] + #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. + #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. + #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. + + #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] + } + + proc askuser {question} { + #*** !doctools + #[call [fun askuser] [arg question]] + #[para]A basic utility to read an answer from stdin + #[para]The prompt is written to the terminal and then it waits for a user to type something + #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. + #[para](Generic terminal raw vs linemode detection not yet present) + #[para]The user must hit enter to submit the response + #[para]The return value is the string if any that was typed prior to hitting enter. + #[para]The question argument can be manually colourised using the various punk::ansi funcitons + #[example_begin] + # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] + # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { + # puts "Proceeding" + # } else { + # puts "Cancelled by user" + # } + #[example_end] + puts stdout $question + flush stdout + set stdin_state [chan configure stdin] + if {[catch { + package require punk::console + set console_raw [tsv::get console is_raw] + } err_console]} { + #assume normal line mode + set console_raw 0 + } + try { + chan configure stdin -blocking 1 + if {$console_raw} { + punk::console::disableRaw + set answer [gets stdin] + punk::console::enableRaw + } else { + set answer [gets stdin] + } + } finally { + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] + } + return $answer + } + + #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] + } + #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 + } + + #e.g linesort -decreasing $data + proc linesort {args} { + #*** !doctools + #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] + #[para]Sort lines in textblock + #[para]Returns another textblock with lines sorted + #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique + if {[llength $args] < 1} { + error "linesort missing lines argument" + } + set lines [lindex $args end] + set opts [lrange $args 0 end-1] + #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts + list_as_lines [lsort {*}$opts [linelist $lines]] + } + + proc list_as_lines {args} { + #*** !doctools + #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] + #[para]This simply joins the elements of the list with -joinchar + #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines + #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. + if {[set eop [lsearch $args --]] == [llength $args]-2} { + #end-of-opts not really necessary - except for consistency with lines_as_list + set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] + } + if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { + set joinchar [lindex $args 1] + set lines [lindex $args 2] + } elseif {[llength $args] == 1} { + set joinchar "\n" + set lines [lindex $args 0] + } else { + error "list_as_lines usage: list_as_lines ?-joinchar ? " + } + return [join $lines $joinchar] + } + proc list_as_lines2 {args} { + #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? + lassign [tcl::dict::values [punk::args::parse $args withdef { + -joinchar -default \n + @values -min 1 -max 1 + }]] leaders opts values + + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + } + + proc lines_as_list {args} { + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. + #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error + #..because we don't know what to say if there are odd numbers of args + #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work + #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway + + if {[lsearch $args "--"] == [llength $args]-2} { + set opts [lrange $args 0 end-2] + } else { + set opts [lrange $args 0 end-1] + } + #set opts [tcl::dict::merge {-block {}} $opts] + set bposn [lsearch $opts -block] + if {$bposn < 0} { + lappend opts -block {} + } + set text [lindex $args end] + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] + } + #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds + proc lines_as_list2 {args} { + #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults + #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc + #we don't have to decide what is an opt vs a value + #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) + lassign [tcl::dict::values [punk::args::parse $args withdef { + @opts -any 1 + -block -default {} + }]] leaderdict opts valuedict + tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] + } + + # important for pipeline & match_assign + # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? + # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace + set linelist_body { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach code $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + #not sure if this handles more complex hierarchies or mixins etc. + lassign $args obj method + if {![info object isa object $obj]} { + error "show_jump_tables unable to examine '$args'. $obj is not an oo object" + } + #classes are objects too and can have direct methods + if {$method in [info object methods $obj]} { + set data [tcl::unsupported::disassemble objmethod $obj $method] + } else { + if {![info object isa class $obj]} { + set obj [info object class $obj] + } + set data [tcl::unsupported::disassemble method $obj $method] + } + } else { + error "show_jump_tables expected a procname or a class/object and method" + } + set result "" + set in_jt 0 + foreach ln [split $data \n] { + set tln [string trim $ln] + if {!$in_jt} { + if {[string match *jumpTable* $ln]} { + append result $ln \n + set in_jt 1 + } + } else { + if {[string match Command* $tln] || [string match "(*) *" $tln]} { + set in_jt 0 + } else { + append result $ln \n + } + } + } + return $result + } + + proc temperature_f_to_c {deg_fahrenheit} { + return [expr {($deg_fahrenheit -32) * (5/9.0)}] + } + proc temperature_c_to_f {deg_celsius} { + return [expr {($deg_celsius * (9/5.0)) + 32}] + } + + proc interp_sync_package_paths {interp} { + if {![interp exists $interp]} { + error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" + } + interp eval $interp [list set ::auto_path $::auto_path] + interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} + interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] + } + + proc objclone {obj} { + append obj2 $obj {} + } + proc set_clone {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + + + proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { + variable has_twapi + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + } + } + #when using twapi we currently only get the localeid - not the specific defaults + #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this + set default_delim "," + set default_groupsize 3 + + set results [list] + set nums [objclone $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + foreach inputnum $nums { + set number [objclone $inputnum] + #also handle tcl 8.7+ underscores in numbers + set number [string map [list _ "" , ""] $number] + #normalize e.g 2e4 -> 20000.0 + set number [expr {$number}] + + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + lappend results [twapi::format_number $number $localeid -idigits -1] + continue + } else { + #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one + #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? + if {$delim eq ""} {set delim $default_delim} + if {$groupsize eq ""} {set groupsize $default_groupsize} + lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + continue + } + } + #todo - get configured user defaults + if {$delim eq ""} { + set delim $default_delim + } + if {$groupsize eq ""} { + set groupsize $default_groupsize + } + + lappend results [delimit_number $number $delim $groupsize] + } + + if {[llength $results] == 1} { + #keep intrep as string rather than list + return [lindex $results 0] + } + return $results + } + + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { + set number [objclone $unformattednumber] + set number [string map {_ ""} $number] + #normalize using expr - e.g 2e4 -> 20000.0 + set number [expr {$number}] + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number $point+1 end]; + set PostDecimalP 1; + } else { + set point [expr {[string length $number] + 1}] + set PostDecimal ""; + set PostDecimalP 0; + } + + # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr {$FirstNonSpace - 1}]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace $point-1]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize + } + + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} + +tcl::namespace::eval punk::lib::test { + + + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#todo - way to generate 'internal' docs separately? +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::lib::system { + #*** !doctools + #[subsection {Namespace punk::lib::system}] + #[para] Internal functions that are not part of the API + #[list_begin definitions] + + + proc mostFactorsBelow {n} { + ##*** !doctools + #[call [fun mostFactorsBelow] [arg n]] + #[para]Find the number below $n which has the greatest number of factors + #[para]This will get slow quickly as n increases (100K = 1s+ 2024) + set most 0 + set mostcount 0 + for {set i 1} {$i < $n} {incr i} { + set fc [llength [punk::lib::factors $i]] + if {$fc > $mostcount} { + set most $i + set mostcount $fc + } + } + return [list number $most numfactors $mostcount] + } + proc factorCountBelow_punk {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [punk::lib::factors $i]] + } + return $tally + } + proc factorCountBelow_numtheory {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) + package require math::numtheory + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [math::numtheory::factors $i]] + } + return $tally + } + + proc factors2 {x} { + ##*** !doctools + #[call [fun factors2] [arg x]] + #[para]Return a sorted list of factors of x + #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. + set smallfactors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j < $max} { + if {($x % $j) == 0} { + lappend smallfactors $j + lappend largefactors [expr {$x / $j}] + } + incr j + } + #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop + if {($x % $j) == 0} { + if {$j == ($x / $j)} { + lappend smallfactors $j + } + } + return [concat $smallfactors [lreverse $largefactors] $x] + } + + + + # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + set i 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + incr i + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) + switch -- $c { + {"} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } + {[} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "{" { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "}" - + default { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + incr i + } + set incomplete [list] + foreach w $waiting { + #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. + switch -- $w { + {"} { + lappend incomplete $w + } + {]} { + lappend incomplete "\[" + } + "{" {} + "}" { + lappend incomplete "\{" + } + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->awaiting:'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + + #get info about punk nestindex key ie type: list,dict,undetermined + # pdict devel + proc nestindex_info {args} { + set argd [punk::args::parse $args withdef { + -parent -default "" + nestindex + }] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + #??? + + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] +} + +tcl::namespace::eval punk::lib::debug { + proc showdict {args} {} +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::lib +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::lib [tcl::namespace::eval punk::lib { + variable pkg punk::lib + variable version + set version 0.1.2 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm index fa9e8d7c..7377929a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/doc-0.1.0.tm @@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc { cd $original_wd } proc validate {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::punk::mix::commandset::doc::validate - -- -type none -optional 1 -help "end of options marker --" + -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 - } $args] + }] set opt_individual [tcl::dict::get $argd opts -individual] set patterns [tcl::dict::get $argd values patterns] - + #todo - run and validate punk::docgen output set projectdir [punk::repo::find_project] if {$projectdir eq ""} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/layout-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/layout-0.1.0.tm index 05e94a25..47e37909 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/layout-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/layout-0.1.0.tm @@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout { return [join $layouts \n] } + punk::args::define { + @id -id ::punk::mix::commandset::layout::collection::_default + @cmd -name ::punk::mix::commandset::layout::collection::_default + -startdir -type string + -not -type string -multiple 1 + globsearches -default * -multiple 1 + } proc _default {args} { - punk::args::get_dict [subst { - @id -id ::punk::mix::commandset::layout::collection::_default - @cmd -name ::punk::mix::commandset::layout::collection::_default - -startdir -type string - -not -type string -multiple 1 - globsearches -default * -multiple 1 - }] $args + punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default + set tdict_low_to_high [as_dict {*}$args] #convert to screen order - with higher priority at the top diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 98f171c7..8ef36e27 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap { namespace eval lib { #*** !doctools #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] - #[para] Library API functions for punk::mix::commandset::scriptwrap + #[para] Library API functions for punk::mix::commandset::scriptwrap #[list_begin definitions] - + punk::args::define { + @id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders + #*** !doctools + #[call [fun get_wrapper_folders] [arg args] ] + #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo + #[para] Arguments: + # [list_begin arguments] + # [arg_def string args] name-value pairs -scriptpath + # [list_end] + @cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\ + "Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo" + @opts -anyopts 0 + -scriptpath -default "" -type directory\ + -help "" + #todo -help folder within a punk.templates provided area??? + @values -minvalues 0 -maxvalues 0 + } proc get_wrapper_folders {args} { - set argd [punk::args::get_dict { - #*** !doctools - #[call [fun get_wrapper_folders] [arg args] ] - #[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo - #[para] Arguments: - # [list_begin arguments] - # [arg_def string args] name-value pairs -scriptpath - # [list_end] - @id -id ::punk::mix::commandset::scriptwrap - @cmd -name punk::mix::commandset::get_wrapper_folders - - @opts -anyopts 0 - -scriptpath -default "" -type directory\ - -help "" - #todo -help folder within a punk.templates provided area??? - - @values -minvalues 0 -maxvalues 0 - } $args] + set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders] # -- --- --- --- --- --- --- --- --- set opt_scriptpath [dict get $argd opts -scriptpath] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm index bce44dee..f018486d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm @@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs { # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied + punk::args::define { + @id -id ::punk::nav::fs::dirfiles_dict + @cmd -name punk::nav::fs::dirfiles_dict + @opts -any 0 + -searchbase -default "" + -tailglob -default "\uFFFF" + #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) + -with_sizes -default "\uFFFF" -type string + -with_times -default "\uFFFF" -type string + @values -min 0 -max -1 -type string + } proc dirfiles_dict {args} { - set argspecs { - @id -id ::punk::nav::fs::dirfiles_dict - @opts -any 0 - -searchbase -default "" - -tailglob -default "\uFFFF" - #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string - -with_times -default "\uFFFF" -type string - @values -min 0 -max -1 -type string - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict] lassign [dict values $argd] leaders opts vals set searchspecs [dict values $vals] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm index 7a072de4..84bb21c6 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm @@ -1424,7 +1424,6 @@ tcl::namespace::eval punk::netbox::ipam { NOTE1: tenant is the tenant_id (why?) NOTE: This always uses next available IPs. To create a specific IP, use api/ipam/ip-addresses endpoint. - The returned json is just an object if one address created, but a list if multiple. :/ @@ -1434,6 +1433,65 @@ tcl::namespace::eval punk::netbox::ipam { ] ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_create api/ipam/prefixes/{id}/available-ips/ -verb post -body required + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-prefixes_list + @cmd -name punk::netbox::ipam::prefixes_available-prefixes_list -help\ + "ipam_prefixes_available-prefixes_list + GET request for endpoint /ipam/prefixes/{id}/available-prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${[punk::netbox::api_context_names]}} + @opts + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this prefix" + }\ + ] + ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_list api/ipam/prefixes/{id}/available-prefixes/ -verb get -body none + + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-prefixes_create + @cmd -name punk::netbox::ipam::prefixes_available-prefixes_create -help\ + "ipam_prefixes_available-prefixes_create + POST request for endpoint /ipam/prefixes/{id}/available-prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${[punk::netbox::api_context_names]}} + @opts + }\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LIST]\ + { + @values -min 1 -max 2 + id -type integer -help\ + "A unique integer value identifying this prefix" + body -type string -default "" -help\ + { + { + "prefix_length": 0 + } + } + }\ + ] + ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_create api/ipam/prefixes/{id}/available-prefixes/ -verb post -body required + punk::args::define {*}[list\ { @dynamic diff --git a/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm index 23e7264a..a60963a3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm @@ -100,23 +100,68 @@ package require rest # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::netbox::man { - namespace export {[a-z]*} variable PUNKARGS - - #review + ? - proc uri_part_decode {uripart} { - set specialMap {"[" "%5B" "]" "%5D" + " "} - set seqRE {%([0-9a-fA-F]{2})} - set replacement {[format "%c" [scan "\1" "%2x"]]} - set modstr [regsub -all $seqRE [string map $specialMap $uripart] $replacement] - return [encoding convertfrom utf-8 [subst -nobackslash -novariable $modstr]] + namespace path ::punk::netbox + #create ensemble further down - after sub ensembles exist + + namespace eval contextcommands { + variable nextid 0 + variable commandinfo [dict create] + namespace export {man#*} + proc _cleanup {id args} { + #called by trace on command deletion (trace target must accept args even though not used) + variable commandinfo + dict unset $commandinfo $id + } + proc info {id} { + variable commandinfo + punk::netbox::api_contexts [dict get $commandinfo $id context] + } } - proc uri_get_querystring_as_keyval_list {uri} { - set parts [uri::split $uri] - set query ?[dict get $parts query] - set raw_plist [rest::parameters $query] ;#not a dict - can have repeated params (important for _FILTER methods) - return [lmap v $raw_plist {uri_part_decode $v}] + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::man::new + @cmd -name punk::netbox::man::new -help\ + "Create a command with the apicontextid 'curried' in. + e.g + set svr1 [man tclread new] + $svr1 status + $svr1 tenancy tenants list" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${[punk::netbox::api_context_names]}} + @opts + }\ + ] + proc new {args} { + set argd [punk::args::parse $args withid ::punk::netbox::man::new] + set apicontextid [dict get $argd leaders apicontextid] + upvar ::punk::netbox::man::contextcommands::nextid nextid + upvar ::punk::netbox::man::contextcommands::commandinfo commandinfo + set objname "::punk::netbox::man::contextcommands::man#[incr nextid]" + dict set commandinfo $nextid context $apicontextid + set map [dict create\ + about [list ::punk::netbox::man::about]\ + status [list ::punk::netbox::status $apicontextid]\ + info [list ::punk::netbox::man::contextcommands::info $nextid]\ + destroy [list ::rename $objname ""]\ + ] + set nslist [punk::ns::nslist_dict ::punk::netbox::man::*] + set info [lindex $nslist 0] + set subensembles [dict get $info ensembles] + foreach se $subensembles { + #e.g ip-addresses, tenancy + dict set map $se [list ::punk::netbox::man $apicontextid $se] + } + namespace ensemble create -command $objname -map $map + trace add command $objname delete [list ::punk::netbox::man::contextcommands::_cleanup $nextid] + return $objname } } @@ -131,11 +176,11 @@ tcl::namespace::eval punk::netbox::man::prefixes { #[list_begin definitions] namespace export {[a-z]*} - namespace ensemble create + namespace ensemble create -parameters {apicontextid} variable PUNKARGS lappend PUNKARGS [::list\ - [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes list"}} ::punk::netbox::ipam::prefixes_list]\ + [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes::list"}} ::punk::netbox::ipam::prefixes_list]\ {-RETURN -default table -choices {table tableobject list}}\ {-MAXRESULTS -type integer -default -1}\ {@values -min 0 -max 0}\ @@ -143,12 +188,12 @@ tcl::namespace::eval punk::netbox::man::prefixes { #caution: must use ::list to avoid loop proc list {args} { - set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes list"] - set token tclread ;#todo + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::list"] set urlnext "" set requests_allowed 1000 ;#review set resultlist [::list] + set token [dict get $argd leaders apicontextid] set opts [dict get $argd opts] set vals [dict get $argd values] set multis [dict get $argd multis] @@ -179,7 +224,7 @@ tcl::namespace::eval punk::netbox::man::prefixes { set to_go [expr {$maxresults - [llength $resultlist]}] while {$urlnext ne "null"} { if {$urlnext ne ""} { - set urlnext_params [punk::netbox::man::uri_get_querystring_as_keyval_list $urlnext] + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go } @@ -240,117 +285,606 @@ tcl::namespace::eval punk::netbox::man::prefixes { #return [showdict $resultd] } + tcl::namespace::eval available-ips { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + lappend PUNKARGS [::list\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override {\ + @id {-id "::punk::netbox::man::prefixes::available-ips::create"}\ + -RETURN {-default table -choices {list linelist showlistofdicts}}\ + @values {-min 2 -max 2}\ + body {-optional 0}\ + }\ + ::punk::netbox::ipam::prefixes_available-ips_create\ + ]\ + ] + proc create {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::create"] + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set valuedict [dict get $argd values] + set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + set resultlist [punk::netbox::ipam::prefixes_available-ips_create $token {*}$nextopts -RETURN list {*}$vals] + + switch -- $outer_return { + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + showlistofdicts { + return [punk::lib::showdict $resultlist {@*/@*.@*}] + } + jsondump { + #todo + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $resultlist] + return [huddle::jsondump $h] + } + default { + return $resultlist + } + } - #lappend PUNKARGS [::list\ - # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ - # {-RETURN -default table -choices {table tableobject list}} - # ] - lappend PUNKARGS [::list\ - [punk::args::resolved_def\ - -antiglobs {apicontextid @leaders -offset}\ - -override {\ - @id {-id "::punk::netbox::man::prefixes available-ips_list"}\ - -limit {-default 254 -help "Maximum number of entries to return"}\ - -RETURN {-default table -choices {table tableobject list linelist}}\ - @values {-min 1 -max 1}\ - }\ - ::punk::netbox::ipam::prefixes_available-ips_list\ - ]\ - ] - proc available-ips_list {args} { - set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes available-ips_list"] - set token tclread ;#todo + } - set resultlist [::list] - set opts [dict get $argd opts] - set valuedict [dict get $argd values] - set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func - set multis [dict get $argd multis] - set outer_return [dict get $opts -RETURN] - set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely - #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong - set nextopts [::list] - dict for {opt val} $opts { - if {$opt ni $multis} { - lappend nextopts $opt $val - } else { - foreach v $val { - lappend nextopts $opt $v + #lappend PUNKARGS [::list\ + # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ + # {-RETURN -default table -choices {table tableobject list}} + # ] + lappend PUNKARGS [::list\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override {\ + @id {-id "::punk::netbox::man::prefixes::available-ips::list"}\ + -limit {-default 254 -help "Maximum number of entries to return"}\ + -RETURN {-default table -choices {table tableobject list linelist}}\ + @values {-min 1 -max 1}\ + }\ + ::punk::netbox::ipam::prefixes_available-ips_list\ + ]\ + ] + + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::list"] + + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set valuedict [dict get $argd values] + set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + #No paging available at endpoint ipam/prefixes/available-ips - but we can still use limit (but offset doesn't seem to work) + #REVIEW - no way to know if *all* available in a prefix were returned - could/should? have been limited by server setting + #Especially in an ipv6 context - we're *very* unlikely to want to try to get all! (even for a /16 ipv4 it's probably not a very sensible query) + #Default netbox server limit seems to be 1000? review + #setting -limit 0 seems to allow this to be overridden - giving results bounded only by size of the prefix? + set resultlist [punk::netbox::ipam::prefixes_available-ips_list $token {*}$nextopts -RETURN list {*}$vals] + + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}] + foreach ip $resultlist { + if {[dict exists $ip vrf id]} { + set vrfinfo "[dict get $ip vrf id]: [dict get $ip vrf name]" + } else { + set vrfinfo "-" + } + set r [::list\ + [dict get $ip address]\ + [dict get $ip family]\ + $vrfinfo\ + ] + $t add_row $r } } + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + jsondump { + #todo + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $result] + return [huddle::jsondump $h] + } + default { + return $resultlist + } + } + #return [showdict $resultd] } - #Now opts is a list with possible repeated options! (for flags that have -multiple true) - #No paging available at endpoint ipam/prefixes/available-ips - but we can still use limit (but offset doesn't seem to work) - #REVIEW - no way to know if *all* available in a prefix were returned - could/should? have been limited by server setting - #Especially in an ipv6 context - we're *very* unlikely to want to try to get all! (even for a /16 ipv4 it's probably not a very sensible query) - #Default netbox server limit seems to be 1000? review - #setting -limit 0 seems to allow this to be overridden - giving results bounded only by size of the prefix? - set resultlist [punk::netbox::ipam::prefixes_available-ips_list $token {*}$nextopts -RETURN list {*}$vals] - if {$outer_return in {table tableobject}} { - package require textblock - set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}] - foreach ip $resultlist { - if {[dict exists $ip vrf id]} { - set vrfinfo "[dict get $ip vrf id]: [dict get $ip vrf name]" + } + + tcl::namespace::eval available-prefixes { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + lappend PUNKARGS [::list\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override {\ + @id {-id "::punk::netbox::man::prefixes::available-prefixes::create"}\ + -RETURN {-default table -choices {list linelist showlistofdicts}}\ + @values {-min 2 -max 2}\ + body {-optional 0}\ + }\ + ::punk::netbox::ipam::prefixes_available-prefixes_create\ + ]\ + ] + proc create {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::create"] + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set valuedict [dict get $argd values] + set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val } else { - set vrfinfo "-" + foreach v $val { + lappend nextopts $opt $v + } } - set r [::list\ - [dict get $ip address]\ - [dict get $ip family]\ - $vrfinfo\ - ] - $t add_row $r - } - } - switch -- $outer_return { - table { - set result [$t print] - $t destroy - return $result } - tableobject { - return $t + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + set resultlist [punk::netbox::ipam::prefixes_available-prefixes_create $token {*}$nextopts -RETURN list {*}$vals] + + switch -- $outer_return { + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + showlistofdicts { + return [punk::lib::showdict $resultlist {@*/@*.@*}] + } + jsondump { + #todo + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $resultlist] + return [huddle::jsondump $h] + } + default { + return $resultlist + } } - linelist { - set ret "" - foreach r $resultlist { - append ret $r \n + + + } + + #lappend PUNKARGS [::list\ + # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ + # {-RETURN -default table -choices {table tableobject list}} + # ] + lappend PUNKARGS [::list\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override {\ + @id {-id "::punk::netbox::man::prefixes::available-prefixes::list"}\ + -limit {-default 254 -help "Maximum number of entries to return"}\ + -RETURN {-default table -choices {table tableobject list linelist}}\ + @values {-min 1 -max 1}\ + }\ + ::punk::netbox::ipam::prefixes_available-prefixes_list\ + ]\ + ] + + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::list"] + + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set valuedict [dict get $argd values] + set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } } - return $ret } - jsondump { - #todo - package require huddle::json - #pretty-print via huddle (inefficient review) - set h [huddle::json::json2huddle parse $result] - return [huddle::jsondump $h] + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + set resultlist [punk::netbox::ipam::prefixes_available-prefixes_list $token {*}$nextopts -RETURN list {*}$vals] + + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}] + foreach pfx $resultlist { + if {[dict exists $pfx vrf id]} { + set vrfinfo "[dict get $pfx vrf id]: [dict get $pfx vrf name]" + } else { + set vrfinfo "-" + } + set r [::list\ + [dict get $pfx prefix]\ + [dict get $pfx family]\ + $vrfinfo\ + ] + $t add_row $r + } } - default { - return $resultlist + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + jsondump { + #todo + package require huddle::json + #pretty-print via huddle (inefficient review) + set h [huddle::json::json2huddle parse $result] + return [huddle::jsondump $h] + } + default { + return $resultlist + } } + #return [showdict $resultd] } - #return [showdict $resultd] + + } + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::netbox::man ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::netbox::man::tenancy { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + tcl::namespace::eval tenants { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + #we're overriding a resolved_def which was dynamic + # - we need to ensure the new definition is also dynamic + # - todo - override rawdef instead? (convenience functions for override of rawdef is missing in punk::args) + lappend PUNKARGS [::list\ + @dynamic\ + [punk::args::resolved_def\ + -antiglobs {@leaders @values -RETURN}\ + -override {@id {-id "::punk::netbox::man::tenancy::tenants::list"} apicontextid {-choices {${[punk::netbox::api_context_names]}}}}\ + ::punk::netbox::tenancy::tenants_list\ + ]\ + {-RETURN -default table -choices {table tableobject list linelist}}\ + {-MAXRESULTS -type integer -default -1}\ + {@values -min 0 -max 0}\ + ] + + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::tenancy::tenants::list"] + + set urlnext "" + set requests_allowed 1000 ;#Sanity check - consider making an option - review + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set vals [dict get $argd values] + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + set maxresults [dict get $opts -MAXRESULTS] + set opts [dict remove $opts -MAXRESULTS] + set initial_pagelimit [dict get $opts -limit] + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + if {$maxresults == -1} { + set maxresults $initial_pagelimit + } + if {$maxresults < $initial_pagelimit} { + punk::netbox::man::system::dupkeylist_setfirst nextopts -limit $maxresults + } + set to_go [expr {$maxresults - [llength $resultlist]}] + while {$urlnext ne "null"} { + if {$urlnext ne ""} { + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] + if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { + punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go + } + punk::netbox::man::system::optionlistvar_sync_from_urlparams nextopts $urlnext_params + } + puts "-->next:$urlnext nextopts:$nextopts vals:$vals" + set resultd [punk::netbox::tenancy::tenants_list $token {*}$nextopts -RETURN dict {*}$vals] + set urlnext [dict get $resultd next] + set batch [dict get $resultd results] + lappend resultlist {*}$batch + + set to_go [expr {$maxresults - [llength $resultlist]}] + if {$to_go <= 0} {break} + incr requests_allowed -1 + if {$requests_allowed < 1} {break} + } + + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {id name slug description group sites racks devices vms IPs}] + foreach ten $resultlist { + + if {[dict exists $ten group id]} { + set group "[dict get $ten group id]: [dict get $ten group slug]" + } else { + set group [dict get $ten group] ;#probably null + } + set r [::list\ + [dict get $ten id]\ + [dict get $ten name]\ + [dict get $ten slug]\ + [dict get $ten description]\ + $group\ + [dict get $ten site_count]\ + [dict get $ten rack_count]\ + [dict get $ten device_count]\ + [dict get $ten virtualmachine_count]\ + [dict get $ten ipaddress_count]\ + ] + $t add_row $r + } + } + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + default { + return $resultlist + } + } + } + + } + +} +tcl::namespace::eval punk::netbox::man::virtualization { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + tcl::namespace::eval virtual-machines { + namespace export {[a-z]*} + namespace ensemble create -parameters {apicontextid} + variable PUNKARGS + + lappend PUNKARGS [::list\ + [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::virtualization::virtual-machines::list"}} ::punk::netbox::virtualization::virtual-machines_list]\ + {-RETURN -default table -choices {table tableobject list linelist}}\ + {-MAXRESULTS -type integer -default -1}\ + {@values -min 0 -max 0}\ + ] + proc list {args} { + set argd [punk::args::parse $args withid "::punk::netbox::man::virtualization::virtual-machines::list"] + + set urlnext "" + set requests_allowed 1000 ;#Sanity check - consider making an option - review + set resultlist [::list] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set vals [dict get $argd values] + set multis [dict get $argd multis] + set outer_return [dict get $opts -RETURN] + set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely + set maxresults [dict get $opts -MAXRESULTS] + set opts [dict remove $opts -MAXRESULTS] + set initial_pagelimit [dict get $opts -limit] + #we can't just pass through 'multi' opts even if only one was supplied - list level is wrong + set nextopts [::list] + dict for {opt val} $opts { + if {$opt ni $multis} { + lappend nextopts $opt $val + } else { + foreach v $val { + lappend nextopts $opt $v + } + } + } + #Now opts is a list with possible repeated options! (for flags that have -multiple true) + + if {$maxresults == -1} { + set maxresults $initial_pagelimit + } + if {$maxresults < $initial_pagelimit} { + punk::netbox::man::system::dupkeylist_setfirst nextopts -limit $maxresults + } + set to_go [expr {$maxresults - [llength $resultlist]}] + while {$urlnext ne "null"} { + if {$urlnext ne ""} { + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] + if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { + punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go + } + punk::netbox::man::system::optionlistvar_sync_from_urlparams nextopts $urlnext_params + } + puts "-->next:$urlnext nextopts:$nextopts vals:$vals" + set resultd [punk::netbox::virtualization::virtual-machines_list $token {*}$nextopts -RETURN dict {*}$vals] + set urlnext [dict get $resultd next] + set batch [dict get $resultd results] + lappend resultlist {*}$batch + + set to_go [expr {$maxresults - [llength $resultlist]}] + if {$to_go <= 0} {break} + incr requests_allowed -1 + if {$requests_allowed < 1} {break} + } + + if {$outer_return in {table tableobject}} { + package require textblock + set t [textblock::list_as_table -return tableobject -colheaders {id name site primary_ip4 tags}] + foreach vm $resultlist { + + if {[dict exists $vm site id]} { + set site "[dict get $vm site id]: [dict get $vm site slug]" + } else { + set site [dict get $vm site] ;#probably null + } + if {[dict exists $vm primary_ip4 id]} { + set ip4 [dict get $vm primary_ip4 address] + } else { + set ip4 "" + } + set taglist [dict get $vm tags] + set tagblock "" + foreach taginfo $taglist { + set slug [dict get $taginfo slug] + set rgb [dict get $taginfo color] + append tagblock "[a+ Rgb#$rgb rgb#$rgb-contrasting]$slug[a] " + } + set r [::list\ + [dict get $vm id]\ + [dict get $vm name]\ + $site\ + $ip4\ + $tagblock\ + ] + $t add_row $r + } + } + switch -- $outer_return { + table { + set result [$t print] + $t destroy + return $result + } + tableobject { + return $t + } + linelist { + set ret "" + foreach r $resultlist { + append ret $r \n + } + return $ret + } + default { + return $resultlist + } + } + } + + } + +} + tcl::namespace::eval punk::netbox::man::ip-addresses { namespace export {[a-z]*} - namespace ensemble create + namespace ensemble create -parameters {apicontextid} variable PUNKARGS lappend PUNKARGS [::list\ - [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::ip-addresses list"}} ::punk::netbox::ipam::ip-addresses_list]\ + [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::ip-addresses::list"}} ::punk::netbox::ipam::ip-addresses_list]\ {-RETURN -default table -choices {table tableobject list linelist}}\ {-MAXRESULTS -type integer -default -1}\ {@values -min 0 -max 0}\ @@ -358,15 +892,15 @@ tcl::namespace::eval punk::netbox::man::ip-addresses { #caution: must use ::list to avoid loop proc list {args} { - set argd [punk::args::parse $args withid "::punk::netbox::man::ip-addresses list"] - set token tclread ;#todo + set argd [punk::args::parse $args withid "::punk::netbox::man::ip-addresses::list"] set urlnext "" set requests_allowed 1000 ;#Sanity check - consider making an option - review set resultlist [::list] - set opts [dict get $argd opts] - set vals [dict get $argd values] - set multis [dict get $argd multis] + set token [dict get $argd leaders apicontextid] + set opts [dict get $argd opts] + set vals [dict get $argd values] + set multis [dict get $argd multis] set outer_return [dict get $opts -RETURN] set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely set maxresults [dict get $opts -MAXRESULTS] @@ -394,7 +928,7 @@ tcl::namespace::eval punk::netbox::man::ip-addresses { set to_go [expr {$maxresults - [llength $resultlist]}] while {$urlnext ne "null"} { if {$urlnext ne ""} { - set urlnext_params [punk::netbox::man::uri_get_querystring_as_keyval_list $urlnext] + set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext] if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go } @@ -479,7 +1013,41 @@ tcl::namespace::eval punk::netbox::man::ip-addresses { } +#now all sub-ensembles exist - create the ensemble for punk::netbox::man +# - we use a map to exclude any exported procs within the man namespace that don't accept the apicontextid parameter (e.g about) +tcl::namespace::eval punk::netbox::man { + namespace export {[a-z]*} + + set emap [dict create\ + new [list ::punk::netbox::man::new]\ + status [list ::punk::netbox::status]\ + ] + set nslist [punk::ns::nslist_dict ::punk::netbox::man::*] + set info [lindex $nslist 0] + set subensembles [dict get $info ensembles] + foreach se $subensembles { + #e.g ip-addresses, tenancy + dict set emap $se [list ::punk::netbox::man::$se] + } + namespace ensemble create -parameters apicontextid -map $emap +} + tcl::namespace::eval punk::netbox::man::system { + #review + ? + proc uri_part_decode {uripart} { + set specialMap {"[" "%5B" "]" "%5D" + " "} + set seqRE {%([0-9a-fA-F]{2})} + set replacement {[format "%c" [scan "\1" "%2x"]]} + set modstr [regsub -all $seqRE [string map $specialMap $uripart] $replacement] + return [encoding convertfrom utf-8 [subst -nobackslash -novariable $modstr]] + } + + proc uri_get_querystring_as_keyval_list {uri} { + set parts [uri::split $uri] + set query ?[dict get $parts query] + set raw_plist [rest::parameters $query] ;#not a dict - can have repeated params (important for _FILTER methods) + return [lmap v $raw_plist {uri_part_decode $v}] + } #update/add specific members of optionlistvar params in dashed -option format from urlparams in undashed format #members: offset,limit -> -offset,-limit @@ -584,8 +1152,7 @@ tcl::namespace::eval punk::netbox::man { lappend PUNKARGS [list { @id -id "(package)punk::netbox::man" @package -name "punk::netbox::man" -help\ - "Package - Description" + "Management wrapper over netbox rest API" }] namespace eval argdoc { @@ -675,7 +1242,13 @@ namespace eval ::punk::args::register { lappend ::punk::args::register::NAMESPACES\ ::punk::netbox::man\ ::punk::netbox::man::prefixes\ - ::punk::netbox::man::ip-addresses + ::punk::netbox::man::prefixes::available-ips\ + ::punk::netbox::man::prefixes::available-prefixes\ + ::punk::netbox::man::ip-addresses\ + ::punk::netbox::man::tenancy\ + ::punk::netbox::man::tenancy::tenants\ + ::punk::netbox::man::virtualization\ + ::punk::netbox::man::virtualization::virtual-machines\ } # ----------------------------------------------------------------------------- diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index b89bc021..b8ad757f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -21,7 +21,7 @@ package require punk::lib package require punk::args tcl::namespace::eval ::punk::ns::evaluator { - #eval-_NS_xxx_NS_etc procs + #eval-_NS_xxx_NS_etc procs } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -33,7 +33,7 @@ tcl::namespace::eval punk::ns { } variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns - namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp + namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp pkguse cmdtype resolve_command synopsis namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc catch { @@ -43,7 +43,7 @@ tcl::namespace::eval punk::ns { #debug level punk.ns.compile 3 } - #leading colon makes it hard (impossible?) to call directly if not within the namespace + #leading colon makes it hard (impossible?) to call directly if not within the namespace proc ns/ {v {ns_or_glob ""} args} { variable ns_current ;#change active ns of repl by setting ns_current @@ -67,7 +67,7 @@ tcl::namespace::eval punk::ns { if {$ns_or_glob eq ""} { set is_absolute 1 set ns_queried $ns_current - set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] set has_globchars [regexp {[*?]} $ns_or_glob] @@ -78,10 +78,10 @@ tcl::namespace::eval punk::ns { } set ns_current $ns_or_glob set ns_queried $ns_current - tailcall ns/ $v "" + tailcall ns/ $v "" } else { set ns_queried $ns_or_glob - set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] } } else { if {!$has_globchars} { @@ -91,10 +91,10 @@ tcl::namespace::eval punk::ns { } set ns_current $nsnext set ns_queried $nsnext - set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] } else { set ns_queried [nsjoin $ns_current $ns_or_glob] - set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] } } } @@ -103,7 +103,7 @@ tcl::namespace::eval punk::ns { if {$ns_current in [info commands $ns_current] } { if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { if {[llength $ensemble_info] > 0} { - #this namespace happens to match ensemble command. + #this namespace happens to match ensemble command. #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" } @@ -158,7 +158,7 @@ tcl::namespace::eval punk::ns { } else { set out [get_nslist -match [nsjoin $nsq *] -types [list all]] } - #set out [nslist [nsjoin $nsq *]] + #set out [nslist [nsjoin $nsq *]] set ns_current $nsq append out "\n$ns_current" return $out @@ -252,8 +252,15 @@ tcl::namespace::eval punk::ns { } else { set nsfq $ns } - set ns_script [nseval_ifexists_getscript $nsfq] - uplevel 1 [list {*}$ns_script $script] + if {[lsearch [nsparts $nsfq] :*] >=0} { + #weird_ns + set ns_script [nseval_ifexists_getscript $nsfq] + return [uplevel 1 [list {*}$ns_script $script]] + } else { + if {[namespace exists $nsfq]} { + return [namespace eval $nsfq $script] + } + } } proc nseval_ifexists_getscript {location} { set parts [nsparts $location] @@ -323,7 +330,7 @@ tcl::namespace::eval punk::ns { } #Note nsjoin,nsjoinall,nsprefix,nstail are string functions that don't care about namespaces in existence. - #Some functions in punk::ns are + #Some functions in punk::ns are proc nsjoin {prefix name} { if {[string match ::* $name]} { @@ -422,19 +429,19 @@ tcl::namespace::eval punk::ns { #return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) #'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y - #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them + #Can be used to either support use of such namespaces/commands - or as part of validation to disallow them #as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) - #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string + #Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string #This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' - #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah - # is this :: punk :etc :blah or :: punk :etc: blah - #clearly leading/trailing colons in namespaces and commands are just a bad idea. + #NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah + # is this :: punk :etc :blah or :: punk :etc: blah + #clearly leading/trailing colons in namespaces and commands are just a bad idea. #nsparts will prefer leading colon (ie greedy on ::) #This is important to support leading colon commands such as :/ # ie ::punk:::jjj:::etc -> :: punk :jjj :etc proc nsparts {nspath} { set nspath [string map {:::: ::} $nspath] - set mapped [string map {:: \u0FFF} $nspath] + set mapped [string map {:: \u0FFF} $nspath] set parts [split $mapped \u0FFF] if {[lindex $parts end] eq ""} { @@ -526,7 +533,7 @@ tcl::namespace::eval punk::ns { proc nstree {{location ""}} { if {![string match ::* $location]} { set nscaller [uplevel 1 {::namespace current}] - set location [nsjoin $nscaller $location] + set location [nsjoin $nscaller $location] } list_as_lines [nstree_list $location] } @@ -548,18 +555,18 @@ tcl::namespace::eval punk::ns { set subnslist [dict get $opts -subnslist] set allbelow [dict get $opts -allbelow] ;#whether to return matches longer than the matched glob-path # -- ---- --- --- --- --- - + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $location]] set has_globchars [regexp {[*?]} $ns_absolute] ;#don't use regexes on plain namespaces with no glob chars if {!$has_globchars && !$allbelow && ![llength $subnslist]} { - #short circuit trivial case + #short circuit trivial case return [list $location] } - - set base "" + + set base "" set tailparts [list] - if {$CALLDEPTH == 0} { + if {$CALLDEPTH == 0} { set parts [nsparts $ns_absolute] lset parts 0 :: set idx 0 @@ -577,12 +584,12 @@ tcl::namespace::eval punk::ns { set base $ns_absolute } } else { - set base $location + set base $location set tailparts $subnslist } if {![tcl::namespace::exists $base]} { return [list] - } + } #set parent [nsprefix $ns_absolute] #set tail [nstail $ns_absolute] @@ -592,19 +599,19 @@ tcl::namespace::eval punk::ns { #puts "->base:$base tailparts:$tailparts allchildren: $allchildren" #puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" - #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx + #** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx if {[llength $tailparts]} { set nextglob [lindex $tailparts 0] if {$nextglob eq "**"} { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } elseif {[regexp {[*]{2}$} $nextglob]} { set nslist [list] lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] foreach ch $nsmatches { lappend nslist $ch - #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] - lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] - } + #lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] + } } else { #lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) set nslist [list] @@ -612,7 +619,7 @@ tcl::namespace::eval punk::ns { if {[llength $tailparts] >1 || $allbelow} { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { #if only one tailpart remaining and not $allbelow - then we already have what we need @@ -626,13 +633,13 @@ tcl::namespace::eval punk::ns { set nslist [list] foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] + lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] } } else { set nslist $allchildren } #set nsmatches $allchildren - #set nslist [nstree_list $base -subnslist {} -allbelow 0] + #set nslist [nstree_list $base -subnslist {} -allbelow 0] } set nslist [lsort -unique $nslist] @@ -652,10 +659,10 @@ tcl::namespace::eval punk::ns { foreach ch $nsmatches { lappend nslist $ch - lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] + lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] } } else { - set nslist [nstree_list $base -subnslist {} -allbelow 1] + set nslist [nstree_list $base -subnslist {} -allbelow 1] } } @@ -670,14 +677,14 @@ tcl::namespace::eval punk::ns { if {$base ni $nslist} { #puts stderr "> adding $base to $nslist" set nslist [list $base {*}$nslist] - } + } if {$has_globchars} { if {$allbelow} { foreach ns $nslist { if {[globmatchns ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { set nslist_filtered [struct::list::Lfilter $nslist [list globmatchns ${ns_absolute}]] } @@ -687,7 +694,7 @@ tcl::namespace::eval punk::ns { if {[string equal ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { lappend nslist_filtered $ns } - } + } } else { #set nslist_filtered [struct::list::Lfilter $nslist [list string match ${ns_absolute}]] set nslist_filtered [list $ns_absolute] @@ -705,9 +712,54 @@ tcl::namespace::eval punk::ns { if {$ansicodes eq ""} { return $usageinfo_char } elseif {$ansicodes eq "\UFFEF"} { - return " [a+ brightyellow]$usageinfo_char[a]" + return "[a+ brightyellow]$usageinfo_char[a]" + } else { + return "[a+ {*}$ansicodes]$usageinfo_char[a]" + } + } + + punk::args::define { + @id -id ::punk::ns::Cmark + @cmd -name punk::ns::Cmark + @leaders + type -choices {oo ooc ooo punkargs ensemble native} -choicelabels { + oo " symbol \u25c6" + ooc " symbol \u25c7" + ooo " symbol \u25c8" + punkargs " symbol \U1f6c8" + ensemble " symbol \u24ba" + native " symbol \u24c3" + unknown " symbol \u2370" + } + @opts + @values -min 0 -max -1 + ansiname -type string -optional 1 -multiple 1 -help\ + "ansi names as accepted by punk::ansi::a+ + e.g + red bold + (Not raw ansi codes)" + } + proc Cmark {args} { + if {[llength $args] == 0} { + punk::args::parse {} withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + set type [lindex $args 0] + set type [tcl::prefix::match -error "" {oo ooc ooo punkargs ensemble native unknown} $type] + set ansinames [lrange $args 1 end] + switch -- $type { + oo - ooc - ooo - punkargs - ensemble - native - unknown {} + default { + #punk::args::usage ::punk::ns::Cmark + punk::args::parse $args withid ::punk::ns::Cmark + return; #should be unreachable - parse should raise usage error + } + } + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + if {[llength $ansinames]} { + return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type][punk::ansi::a]" } else { - return " [a+ {*}$ansicodes]$usageinfo_char[a]" + return [dict get $marks $type] } } @@ -720,7 +772,7 @@ tcl::namespace::eval punk::ns { -nsdict ""\ ] set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- set fq_glob [dict get $opts -match] set requested_types [dict get $opts -types] set opt_nsdict [dict get $opts -nsdict] @@ -749,7 +801,7 @@ tcl::namespace::eval punk::ns { } foreach t $types { switch -- $t { - oo - all - + oo - all - children - commands - exported - imported - aliases - procs - ensembles - ooclasses - ooobjects - ooprivateobjects - ooprivateclasses - native - coroutines - interps - zlibstreams {} default { error "Unrecognised namespace member type: $t known types: $known_types oo all" @@ -783,19 +835,19 @@ tcl::namespace::eval punk::ns { set usageinfo [list] if {$opt_nsdict eq ""} { - set nsmatches [get_ns_dicts $fq_glob -allbelow 0] + set nsmatches [get_ns_dicts $fq_glob -allbelow 0] set itemcount 0 set matches_with_results [list] foreach nsinfo $nsmatches { - set itemcount [dict get $nsinfo itemcount] + set itemcount [dict get $nsinfo itemcount] if {$itemcount > 0} { lappend matches_with_results $nsinfo - } + } } if {[llength $matches_with_results] == 1} { set contents [lindex $matches_with_results 0] } elseif {[llength $matches_with_results] > 1} { - puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" + puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" set contents [lindex $matches_with_results 0] } else { return "- no results -" @@ -806,7 +858,7 @@ tcl::namespace::eval punk::ns { return "- no results -" } } - set ns [dict get $contents location] + set ns [dict get $contents location] package require overtype if {"children" in $types} { @@ -871,19 +923,19 @@ tcl::namespace::eval punk::ns { } #elements are commands and possibly renamed aliases which may or may not have been renamed into the current namespace - #a command could be an empty string or something else weird. + #a command could be an empty string or something else weird. #Primarily just to handle empty string command - we will wrap each command as a 2-part element here #(our foreach loop needs to ignore missing commands - but not empty string) set elements [lmap v $commands {list c $v}] set seencmds [list] - set masked [list] ;# + set masked [list] ;# #jmn #set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] foreach a $aliases { if {[list c $a] in $elements} { - #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo + #possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo #we can detect masking by proc/ensemble/oo - but not by a binary extension loaded after the rename: REVIEW if {$a in $cmdsets} { #we have an alias that is also a known other command-type @@ -896,15 +948,15 @@ tcl::namespace::eval punk::ns { } } set elements [lsort -index 1 $elements] - - + + set numelements [llength $elements] if {$numelements} { set split1 [expr {int(ceil($numelements/4.0))}] set elements1 [lrange $elements 0 $split1-1] set remaining3 [lrange $elements $split1 end] - set numremaining3 [llength $remaining3] + set numremaining3 [llength $remaining3] set split2 [expr {int(ceil($numremaining3/3.0))}] set elements2 [lrange $remaining3 0 $split2-1] set remaining2 [lrange $remaining3 $split2 end] @@ -1019,12 +1071,12 @@ tcl::namespace::eval punk::ns { } } if {$cmd in $usageinfo} { - set u [Usageinfo_mark brightgreen] + set u " [Cmark punkargs brightgreen]" } else { set u "" } set cmd$i "${prefix} $c$cmd_display$u" - #set c$i $c + #set c$i $c set c$i "" lappend seencmds $cmd } @@ -1033,7 +1085,7 @@ tcl::namespace::eval punk::ns { #lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] lappend displaylist $a1[overtype::left $col1 $ch1][a]$a1[overtype::left $col2 $ch2][a]$c1[overtype::left $col3 $cmd1][a]$c2[overtype::left $col4 $cmd2][a]$c3[overtype::left $col5 $cmd3][a]$c4$cmd4[a] } - + return [list_as_lines $displaylist] } proc nspath_here_absolute {{nspath "\uFFFF"}} { @@ -1060,12 +1112,13 @@ tcl::namespace::eval punk::ns { return [nsjoin $base $nspath] } + variable has_textblock set has_textblock [expr {![catch {package require textblock}]}] if {$has_textblock} { interp alias "" ::punk::ns::Block_width "" textblock::width - } else { - #maint - equiv of textblock::width + } else { + #maint - equiv of textblock::width proc Block_width {textblock} { if {$textblock eq ""} { return 0 } if {[tcl::string::last \t $textblock] >=0} { @@ -1085,38 +1138,55 @@ tcl::namespace::eval punk::ns { return [punk::char::ansifreestring_width $textblock] } } - proc nslist {{glob "*"} args} { - set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] - if {[dict exists $args -match]} { - #review - presumably this is due to get_nslist taking -match? - error "nslist requires positional argument 'glob' instead of -match option" - } - set defaults [dict create\ - -match $ns_absolute\ - -nspathcommands 0\ - ] - set opts [dict merge $defaults $args] + punk::args::define { + @id -id ::punk::ns::nslist + @cmd -name punk::ns::nslist -help\ + "Return a textual representation of + the child namespaces and commands within + the namespace(s) matched by glob." + @opts + -nspathcommands -type boolean -default 0 + -types + @values -min 0 -max -1 + glob -multiple 1 -optional 1 -default "*" + } + proc nslist {args} { + set argd [punk::args::parse $args withid ::punk::ns::nslist] + lassign [dict values $argd] leaders opts values received solos multis + + #if {[dict exists $args -match]} { + # #review - presumably this is due to get_nslist taking -match? + # error "nslist requires positional argument 'glob' instead of -match option" + #} + #set defaults [dict create\ + # -match $ns_absolute\ + # -nspathcommands 0\ + #] + #set opts [dict merge $defaults $args] # -- --- --- set opt_nspathcommands [dict get $opts -nspathcommands] # -- --- --- - - - set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + set globlist [dict get $values glob] set with_results [list] - foreach nsdict $ns_matches { - if {[dict get $nsdict itemcount]>0} { - lappend with_results $nsdict + foreach glob $globlist { + set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] + set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] + foreach nsdict $ns_matches { + if {[dict get $nsdict itemcount]>0} { + lappend with_results $nsdict + } } } - #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' + #special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' set count_with_results [llength $with_results] set output "" + variable has_textblock foreach nsdict $with_results { - dict set opts -nsdict $nsdict - set block [get_nslist {*}$opts] + set loc [dict get $nsdict location] + set block [get_nslist -nsdict $nsdict -match ${loc}::* {*}$opts] #if {[string first \n $block] < 0} { # #single line # set width [Block_width [list $block]] @@ -1125,7 +1195,7 @@ tcl::namespace::eval punk::ns { #} set width [Block_width $block] - #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location + #if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location if {$count_with_results > 1 || [regexp {[*?]} [nsprefix $ns_absolute]]} { append output \n [dict get $nsdict location] } @@ -1139,17 +1209,24 @@ tcl::namespace::eval punk::ns { } else { append path_text \n " also resolving cmds in namespace paths:" set nspathdict [dict get $nsdict namespacepath] - dict for {k v} $nspathdict { - set cmds [dict get $v commands] - append path_text \n " path: $k" - append path_text \n " cmds: $cmds" + if {!$has_textblock} { + dict for {k v} $nspathdict { + set cmds [dict get $v commands] + append path_text \n " path: $k" + append path_text \n " cmds: $cmds" + } + } else { + dict for {k v} $nspathdict { + set t [textblock::list_as_table -title $k -columns 6 [lsort [dict get $v commands]]] + append path_text \n $t + } } } append output $path_text set path_text_width [Block_width $path_text] - append output \n [string repeat - [expr {max($width,$path_text_width)}]] + append output \n [string repeat - [expr {max($width,$path_text_width)}]] } elseif {$count_with_results > 1 && $width > 0 } { - append output \n [string repeat - $width] + append output \n [string repeat - $width] } } return $output @@ -1160,7 +1237,7 @@ tcl::namespace::eval punk::ns { return [get_ns_dicts $ns_absolute {*}$args] } - #info cmdtype available in 8.7+ + #info cmdtype available in 8.7+ #safe interps also seem to have it disabled for some reason #we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc #IMPORTANT: don't detect easy types such as proc/import here - caller needs the 'na' to do the proper fallback @@ -1227,7 +1304,7 @@ tcl::namespace::eval punk::ns { } #we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller #also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! - return na + return na } #non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob #returns a list of dicts even if only one ns matched @@ -1260,17 +1337,18 @@ tcl::namespace::eval punk::ns { set glob [nstail $fq_glob] set matched_namespaces [nstree_list $nsglob -allbelow $allbelow] - set report_namespaces [list] + set report_namespaces [list] #special case trailing ** in last segment if {[regexp {[*]{2}$} $glob]} { - lappend report_namespaces {*}$matched_namespaces + lappend report_namespaces {*}$matched_namespaces foreach ns $matched_namespaces { lappend report_namespaces {*}[nstree_list [nsjoin $ns $glob]] } } else { - set report_namespaces $matched_namespaces + set report_namespaces $matched_namespaces } - punk::args::update_definitions $report_namespaces + #puts stderr "---->get_ns_dicts '$fq_glob $args' update_definitions $report_namespaces" + punk::args::update_definitions $report_namespaces set nsdict_list [list] foreach ch $report_namespaces { @@ -1280,27 +1358,27 @@ tcl::namespace::eval punk::ns { } else { set allchildren [nschildren $ch] ; #sorted, only returns 1 level deeper } - + #nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string. # By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {} #set commands [.= nscommands -raw [nsjoin $ch $glob] |> punk::lib::linelist -block {}] set commands [punk::lib::linelist -block {} [nscommands -raw [nsjoin $ch $glob]]] - #by convention - returning just \n represents a single result of the empty string whereas no results + #by convention - returning just \n represents a single result of the empty string whereas no results #after passing through linelist this becomes {} {} which appears as a list of two empty strings. - #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines + #this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines #unless we always return a newline at the tail if there is a result #For this reason nscommands returns a trailing newline - so the last entry should always be empty string - and is a bogus entry - #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. + #We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. if {[lindex $commands end] eq ""} { set commands [lrange $commands 0 end-1] } else { puts stderr "get_ns_dicts WARNING nscommands didn't return a trailing newline - unexpected" } - - + + #JMN - set location $ch + set location $ch set locationparts [nsparts $location] set weird_ns 0 if {[lsearch $locationparts :*] >= 0} { @@ -1309,7 +1387,7 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set exportpatterns [nseval_ifexists $location {::namespace export}] set nspathlist [nseval_ifexists $location {::namespace path}] - } else { + } else { set exportpatterns [tcl::namespace::eval $location {::namespace export}] set nspathlist [tcl::namespace::eval $location {::namespace path}] } @@ -1335,7 +1413,7 @@ tcl::namespace::eval punk::ns { #! info commands can't glob with a weird ns prefix #! info commands with no arguments returns all commands (from global and any other ns in namespace path) #lappend matched {*}[nseval_ifexists $location [list ::info commands [nsjoin ${location} $p]]] - lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { + lappend matched {*}[nseval_ifexists $location [string map [list $location $p] { set allcommands [info commands] set matches [list] foreach c $allcommands { @@ -1360,9 +1438,9 @@ tcl::namespace::eval punk::ns { set allexported [lsort -unique $allexported] #NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace) if {$weird_ns} { - set allprocs [nseval_ifexists $location {::info procs}] + set allprocs [nseval_ifexists $location {::info procs}] } else { - set allprocs [tcl::namespace::eval $location {::info procs}] + set allprocs [tcl::namespace::eval $location {::info procs}] } #set allprocs [nseval $location {::info procs}] set childtails [lmap v $allchildren {nstail $v}] @@ -1382,24 +1460,24 @@ tcl::namespace::eval punk::ns { #use aliases glob - because aliases can be present with or without leading :: #NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases if {$weird_ns} { - set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [nseval_ifexists $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } else { - set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + set raw_aliases [tcl::namespace::eval $location [list ::punk::lib::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. } - #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. + #set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. set aliases [list] foreach a $raw_aliases { if {[string match *:: $a]} { #exception for alias such as ::p::2:: so that it doesn't show up as empty string #lappend aliases :: #JMN - 2023 - better to display an empty string somehow - lappend aliases "" + lappend aliases "" } else { lappend aliases [nstail $a] } } - #NOTE for 'info ...' 'namespace origin|(etc)..' + #NOTE for 'info ...' 'namespace origin|(etc)..' # - use the pattern [namespace eval $location [list $cmd]] #This allows examination of cmds with "bad" names such as empty string or prefixed with single colon. #while these should be rare - we want to handle such edge cases when browsing namespaces. @@ -1433,7 +1511,7 @@ tcl::namespace::eval punk::ns { } if {$weird_origin} { if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { @@ -1444,7 +1522,7 @@ tcl::namespace::eval punk::ns { } } else { if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { - lappend allensembles $cmd + lappend allensembles $cmd } elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { lappend allooobjects $cmd if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { @@ -1454,7 +1532,7 @@ tcl::namespace::eval punk::ns { } } - } + } default { if {$ctype eq "import"} { if {$weird_ns} { @@ -1462,7 +1540,7 @@ tcl::namespace::eval punk::ns { } else { set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] } - #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source + #even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source #ie we don't need to follow a chain of 'imported' results. set origin_location [nsprefix $cmdorigin] set origin_cmd [nstail $cmdorigin] @@ -1491,7 +1569,7 @@ tcl::namespace::eval punk::ns { lappend allensembles $cmd } i-alias - alias { - #review + #review lappend allaliases $cmd } i-object - object { @@ -1520,7 +1598,7 @@ tcl::namespace::eval punk::ns { lappend allzlibstreams $cmd } default { - #there may be other registered types + #there may be other registered types #(extensible with Tcl_RegisterCommandTypeName) lappend allothers $cmd } @@ -1535,7 +1613,7 @@ tcl::namespace::eval punk::ns { #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. set nsorigin [namespace origin ${location}::] } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] + set nsorigin [nseval $location "::namespace origin $cmd"] } else { set nsorigin [namespace origin [nsjoin $location $cmd]] } @@ -1585,12 +1663,12 @@ tcl::namespace::eval punk::ns { set imported $allimported set undetermined $allundetermined } - - #itemcount will overcount if we are including commands as well as procs/exported etc - + + #itemcount will overcount if we are including commands as well as procs/exported etc - set itemcount 0 incr itemcount [llength $childtailmatches] incr itemcount [llength $commands] - + #incr itemcount [llength $procs] #incr itemcount [llength $exported] @@ -1606,6 +1684,7 @@ tcl::namespace::eval punk::ns { set has_punkargs [expr {[info commands ::punk::args::id_exists] ne ""}] set has_tepam [expr {[info exists ::tepam::ProcedureList]}] if {$has_punkargs || $has_tepam} { + set ns_updated [dict create] foreach c $commands { if {$c in $imported} { set fq [namespace origin [nsjoin $location $c]] @@ -1613,7 +1692,7 @@ tcl::namespace::eval punk::ns { #TODO - use which_alias ? set tgt [interp alias "" [nsjoin $location $c]] if {$tgt eq ""} { - set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] + set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] } set word1 [lindex $tgt 0] if {$word1 eq "punk::mix::base::_cli"} { @@ -1623,7 +1702,11 @@ tcl::namespace::eval punk::ns { } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) - set fq $word1 + if {[string match ::* $word1]} { + set fq $word1 + } else { + set fq ::$word1 + } } } else { set fq [nsjoin $location $c] @@ -1631,7 +1714,12 @@ tcl::namespace::eval punk::ns { if {$has_punkargs} { #set id [string trimleft $fq :] set id $fq - punk::args::update_definitions [list [namespace qualifiers $id]] + set id_ns [namespace qualifiers $id] + if {![dict exists $ns_updated $id_ns]} { + #puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" + punk::args::update_definitions [list $id_ns] + dict set ns_updated $id_ns 1 + } if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1675,10 +1763,10 @@ tcl::namespace::eval punk::ns { ] lappend nsdict_list $nsdict } - return $nsdict_list + return $nsdict_list } #Must be no ansi when only single arg used. - #review - ansi codes will be very confusing in some scenarios! + #review - ansi codes will be very confusing in some scenarios! #todo - only output color when requested (how?) or via repltelemetry ? interp alias {} nscommands2 {} .= ,'ok'@0.= { #Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x @@ -1688,13 +1776,13 @@ tcl::namespace::eval punk::ns { ::set commandns [::namespace current] ::set commandlist [::list] #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway - #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed + #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed ::set colors [::list none cyan yellow green] ::set ci 0 ;#colourindex ::set do_raw 0 ::if {[::set posn [::lsearch $searchlist -raw]] >= 0} { ::set searchlist [::lreplace $searchlist $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } ::if {![::llength $searchlist]} { ::lappend searchlist * @@ -1714,7 +1802,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1731,7 +1819,7 @@ tcl::namespace::eval punk::ns { ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } if 0 { @@ -1771,19 +1859,19 @@ tcl::namespace::eval punk::ns { ::list ok [::list result $commandlist] #unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) #we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. - } |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} = 0} { ::set args [::lreplace $args $posn $posn] - ::set do_raw 1 + ::set do_raw 1 } if {![llength $args]} { lappend args * @@ -1801,7 +1889,7 @@ tcl::namespace::eval punk::ns { } ::incr ci ;#colourindex #inspect -label search $search - + ::if {![::llength $search]} { ::set base $commandns ::set what "*" @@ -1817,7 +1905,7 @@ tcl::namespace::eval punk::ns { set weird_ns 0 if {[string match *:::* $base]} { set weird_ns 1 - } + } #important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created if {$weird_ns} { ::if {![nsexists $base]} { @@ -1838,7 +1926,7 @@ tcl::namespace::eval punk::ns { }} $base $what ]] } else { ::if {![::tcl::namespace::exists $base]} { - ::continue + ::continue } ::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] } @@ -1903,7 +1991,7 @@ tcl::namespace::eval punk::ns { info commands ${input} } } - } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + } errM]} { + puts stderr "$errM" + set origin $querycommand + set resolved $querycommand + } + } else { + #fully qualified command specified but doesn't exist + set origin $querycommand + set resolved $querycommand + } + } else { + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand + } else { + #set thispath [uplevel 1 [list ::nsthis $querycommand]] + set thispath [uplevel 1 [list ::punk::ns::nspath_here_absolute $querycommand]] + set targetns [nsprefix $thispath] + set name [nstail $thispath] + set targetparts [nsparts $targetns] + if {[lsearch $targetparts :*] >=0} { + #weird ns + set valid_ns [nsexists $targetns] + } else { + set valid_ns [namespace exists $targetns] + } + if {$valid_ns} { + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + }]} { + set thiscmd [nsjoin $targetns $name] + #relative querycommand specified - but Tcl didn't find a match in namespace path + #assume global (todo - look for namespace match in auto_index first ?) + set origin ::$name + set resolved ::$name + } + } else { + #namespace as relative to current doesn't seem to exist + #Tcl would also attempt to resolve as global + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::resolve_command $querycommand {*}$queryargs]] + } + + set origin $querycommand + set resolved $querycommand + + } + } + } + #ns::cmdtype only detects alias type on 8.7+? + set initial_cmdtype [punk::ns::cmdtype $origin] + switch -- $initial_cmdtype { + na - alias { + #REVIEW - alias entry doesn't necessarily match command! + #consider using which_alias (wiki) + set tgt [interp alias "" $origin] + if {$tgt eq ""} { + set tgt [interp alias "" [string trimleft $origin :]] + } + #first word of tgt may be namespace relative or absolute + if {$tgt ne ""} { + set word1 [lindex $tgt 0] + if {$word1 eq "punk::mix::base::_cli"} { + #special case for punk deck - REVIEW + #e.g punk::mix::base::_cli -extension ::punk::mix::cli + set targetword [lindex $tgt end] + } else { + #todo - alias may have prefilled some leading args - so usage report should reflect that??? + #(possible curried arguments) + #review - curried arguments could be for ensembles! + set targetword $word1 + return [namespace eval :: [list punk::ns::resolve_command $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + } + + + set origin $targetword + #retest cmdtype on modified origin + set cmdtype [punk::ns::cmdtype $origin] + } else { + set cmdtype $initial_cmdtype + } + if {$cmdtype eq "na"} { + #tcl 8.6 + if {[info object isa object $origin]} { + set cmdtype "object" + } + } + } + default { + set cmdtype $initial_cmdtype + } + } + + punk::args::update_definitions [list [namespace qualifiers $origin]] + set id $origin + + + #don't shortcircuit if no args id - need to allow (autodef) even for argumentless query e.g resolve_command dict + if {[punk::args::id_exists $id] && ![llength $queryargs]} { + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + #puts "--->resolve_command '$args' update_definitions [list [namespace qualifiers $origin]]" + if {![punk::args::id_exists $origin]} { + if {[namespace ensemble exists $origin]} { + #review + #todo - check -unknown + #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. + #presumably -choiceprefix should be zero in that case?? + + set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] + + #review - we can have a combination of commands from -map as well as those exported from -namespace + # if and only if -subcommands is specified + + set subcommand_dict [dict create] + set commands [list] + set nscommands [list] + if {[llength [dict get $ensembleinfo -subcommands]]} { + #set exportspecs [namespace eval $ns {namespace export}] + #foreach pat $exportspecs { + # lappend nscommands {*}[info commands ${ns}::$pat] + #} + #when using -subcommands, even unexported commands are available + set nscommands [info commands ${ns}::*] + foreach sub [dict get $ensembleinfo -subcommands] { + if {[dict exists $map $sub]} { + #-map takes precence over same name exported from -namespace + dict set subcommand_dict $sub [dict get $map $sub] + } elseif {"${ns}::$sub" in $nscommands} { + dict set subcommand_dict $sub ${ns}::$sub + } else { + #subcommand probably supplied via -unknown handler? + dict set subcommand_dict $sub "" + } + } + } else { + if {[dict size $map]} { + set subcommand_dict $map + } else { + set exportspecs [namespace eval $ns {namespace export}] + foreach pat $exportspecs { + lappend nscommands {*}[info commands ${ns}::$pat] + } + foreach fqc $nscommands { + dict set subcommand_dict [namespace tail $fqc] $fqc + } + } + } + + + set subcommands [lsort [dict keys $subcommand_dict]] + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs + } + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + #must be exact match - not a prefix + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set resolve_next [list {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + puts "+++> resolve_next: $resolve_next" + + set sub_resolution [resolve_command {*}$resolve_next] + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + + #set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 [llength $params] $querycommand {*}$params $match] + + puts stderr "+++> $sub_resolution" + puts stderr "+++> $f" + dict set sub_resolution args_full $f + return $sub_resolution + } + } + + set choiceinfodict [dict create] + set choicelabeldict [dict create] + + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + dict set choiceinfodict $sub [list [list resolved $subwhat]] + + if {$targettail in [dict get $nsinfo usageinfo]} { + dict lappend choiceinfodict $sub {doctype punkargs} + #dict set choicelabeldict $sub [punk::ns::synopsis $subwhat] + } + if {$targettail in [dict get $nsinfo ensembles]} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + if {$targettail in [dict get $nsinfo ooobjects]} { + if {$targettail in [dict get $nsinfo ooclasses]} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$targettail in [dict get $nsinfo native]} { + dict lappend choiceinfodict $sub {doctype native} + } + } + + + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + set autoid "(autodef)$origin" + set argdef [punk::lib::tstr -return string { + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + Ensemble: ${$origin}" + @leaders -min 1 + }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -ensembleparameter 1 -help {leading ensemble parameter - passed to subcommand}" + } + } + append argdef \n $vline + punk::args::define $argdef + set id $autoid + } + } + #testing where id = $origin or id = (autodef)::$origin + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set specid $id + set specargs $queryargs + if {[llength $queryargs]} { + #JJJ + set spec [punk::args::get_spec $id] + #TODO -form + set form_names [dict get $spec form_names] + + #'subcommands' only allowed in single-form commands - review + set fid [lindex $form_names 0] + + set leadernames [dict get $spec FORMS $fid LEADER_NAMES] + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + #'subcommands' are only present in forms that consist solely of leaders - REVIEW + #(does not have to dispatch on 1st leader - e.g consider ensemble -parameters) + if {[llength $form_names] == 1 && ![llength $optnames] && ![llength $valnames]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + + set leadernames_matched [lrange $leadernames 0 [llength $queryargs]-1] + foreach q $queryargs lname $leadernames_matched { + if {$lname eq ""} { + break + } + set arginfo [dict get $spec FORMS $fid ARG_INFO $lname] + + set allchoices [list] + set choices [punk::args::system::Dict_getdef $arginfo -choices {}] + set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] + set choiceinfo [punk::args::system::Dict_getdef $arginfo -choiceinfo {}] + set is_ensembleparam [punk::args::system::Dict_getdef $arginfo -ensembleparameter 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 {*}$clist + } + if {$is_ensembleparam} { + #review + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + if {![llength $allchoices]} { + #review - only leaders with a defined set of choices are eligible for consideration as a subcommand + lappend nextqueryargs $q + lpop queryargs_untested 0 + set specargs $queryargs_untested + continue + } + + + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + break + } + if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { + #a unique prefix is not sufficient for this arg + break + } + + lappend nextqueryargs $resolved_q + lpop queryargs_untested 0 + if {$resolved_q ne $q} { + #we have our first difference - recurse with new query args + set resolvelist [list {*}$specid {*}$nextqueryargs {*}$queryargs_untested] + set sub_resolution [punk::ns::resolve_command {*}$resolvelist] + #return $sub_resolution + + set sub_origin [dict get $sub_resolution origin] + set sub_argsremaining [dict get $sub_resolution args_remaining] + set sub_resolved [dict get $sub_resolution resolved] + set sub_cmdtype [dict get $sub_resolution cmdtype] + set sub_args_full [dict get $sub_resolution args_full] + puts stderr "===> $sub_resolution" + + return [dict create origin $sub_origin args_remaining $sub_argsremaining resolved $sub_resolved cmdtype $sub_cmdtype args_full $resolvelist] + + } + #check if subcommands so far have a custom args def + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set spec [punk::args::get_spec $currentid] + set form_names [dict get $spec form_names] + set fid [lindex $form_names 0] + + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] + + if {[llength $form_names] != 1} { + break + } + set optnames [dict get $spec FORMS $fid OPT_NAMES] + set valnames [dict get $spec FORMS $fid VAL_NAMES] + if {[llength $optnames] || [llength $valnames]} { + break + } + } else { + set is_subcommand_resolved 0 + set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] + set mapped_subcmd "" + foreach inf $cinfo { + if {[lindex $inf 0] eq "resolved"} { + set mapped_subcmd [lindex $inf 1] + set resolve_next [list {*}$mapped_subcmd {*}$queryargs_untested] + puts "---> resolve_next: $resolve_next" + set sub_resolution [punk::ns::resolve_command {*}$resolve_next] + + set sub_args_remaining [dict get $sub_resolution args_remaining] + set sub_args_full [dict get $sub_resolution args_full] + #set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs {*}$sub_args_remaining] + set f [lreplace $sub_args_full 0 0 {*}$specid {*}$nextqueryargs] + + puts stderr "---> $sub_resolution" + puts stderr "---> $f" + dict set sub_resolution args_full $f + return $sub_resolution + + + #puts stderr "---> $sub_resolution" + #return $sub_resolution + } + } + + #We can get no further with custom defs + #It is possible we have a documented lower level subcommand but missing the intermediate + #e.g if ::trace remove command was specified and is documented - it will be found above + #but if ::trace remove is not documented and the query is "::trace remove com" + #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. + #that's probably ok. + break + } + } + } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs + } + } + + if {[string match (autodef)* $origin]} { + set origin [string range $origin 9 end] + } + + + return [dict create origin $origin args_remaining $queryargs resolved $resolved cmdtype $cmdtype args_full $args] + } + + punk::args::define { + @id -id ::punk::ns::forms + @cmd -name punk::ns::forms -help\ + "Return names for each form of a command" + @opts + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc forms {args} { + set argd [::punk::args::parse $args withid ::punk::ns::forms] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::forms $id + } + punk::args::define { + @id -id ::punk::ns::synopsis + @cmd -name punk::ns::synopsis -help\ + "Return synopsis for each form of a command + on separate lines. + If -form is given, supply only + the synopsis for that form. + " + @opts + -form -type string -default * + -return -type string -default full -choices {full summary dict} + @values -min 1 -max -1 + cmditem -multiple 1 -optional 0 + } + proc synopsis {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set opt_return [dict get $argd opts -return] + set cmdmembers [dict get $argd values cmditem] + + + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set resolved_id [dict get $cmdinfo origin] + set unresolved_args [dict get $cmdinfo args_remaining] + set full_args [dict get $cmdinfo args_full] + + #puts "---punk::args::synopsis resolve_command result: $cmdinfo" + #REVIEW + set n [llength $unresolved_args] + set idparts [lrange $full_args 0 end-$n] + + set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] + if {$syn eq ""} { + return + } + + #when we use list operations on $syn - it can get extra braces due to ANSI - use join to bring back to a string without extraneous bracing + switch -- $opt_return { + full - summary { + set resultstr "" + foreach synline [split $syn \n] { + #append resultstr [join [lreplace $synline 0 0 {*}$idparts] " "] \n + append resultstr [join [lreplace $synline 0 [llength $resolved_id]-1 {*}$idparts] " "] \n + } + set resultstr [string trimright $resultstr \n] + #set resultstr [join [lreplace $syn 0 0 {*}$idparts] " "] + return $resultstr + } + dict { + return $syn + } + } + } + proc synopsis_raw {args} { + set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set form [dict get $argd opts -form] + set cmdmembers [dict get $argd values cmditem] + set cmdinfo [uplevel 1 [list ::punk::ns::resolve_command {*}$cmdmembers]] ;#resolve from calling context + set id [dict get $cmdinfo origin] + ::punk::args::synopsis -form $form $id + } + #todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? # - as this is interactive generally introspection should be ok at the top level # but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? @@ -1989,15 +2596,15 @@ tcl::namespace::eval punk::ns { It supports the following: 1) Procedures or builtins for which a punk::args definition has been loaded. - 2) tepam procedures (returns string form only) + 2) tepam procedures (returns string form only) 3) ensemble commands - auto-generated unless documented via punk::args (subcommands will show with an indicator if they are explicitly documented or are themselves ensembles) - 4) tcl::oo objects - auto-gnerated unless documented via punk::args + 4) tcl::oo objects - auto-gnerated unless documented via punk::args 5) dereferencing of aliases to find underlying command (will not work with some renamed aliases) - Note that native commands commands not explicitly documented will + Note that native commands commands not explicitly documented will generally produce no useful info. For example sqlite3 dbcmd objects could theoretically be documented - but as 'info cmdtype' just shows 'native' they can't (?) be identified as belonging to sqlite3 without @@ -2009,7 +2616,8 @@ tcl::namespace::eval punk::ns { } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - + -form -default 0 -help\ + "Ordinal index or name of command form" -- -type none -help\ "End of options marker Use this if the command to view begins with a -" @@ -2026,19 +2634,21 @@ tcl::namespace::eval punk::ns { #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. if {![dict exists $received -scheme]} { - dict set opts -scheme info + #dict set opts -scheme info + set scheme_received 0 + } else { + set scheme_received 1; #so we know not to override caller's explicit choice } set querycommand [dict get $values commandpath] set queryargs [dict get $values subcommand] #todo - similar to corp? review corp resolution process - #should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented if {[string match ::* $querycommand]} { set targetns [nsprefix $querycommand] set name [nstail $querycommand] - #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global + #don't use 'info commands $querycommand' - or Tcl will use 'namespace path' resolution to find command in another ns or in global #when arginfo given a fully qualified path - we only want an answer for that exact command set nscommands [info commands ${targetns}::*] if {[lsearch -exact $nscommands $querycommand] >= 0} { @@ -2051,14 +2661,14 @@ tcl::namespace::eval punk::ns { set resolved $querycommand } } else { - #fully qualified command specified but doesn't exist + #fully qualified command specified but doesn't exist set origin $querycommand set resolved $querycommand } } else { #relative comandpath if {[string match (autodef)* $querycommand]} { - #pass through - should be found with id lookup + #pass through - should be found with id lookup set origin $querycommand set resolved $querycommand } else { @@ -2091,6 +2701,9 @@ tcl::namespace::eval punk::ns { ##puts "THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$queryargs]] if {$nscaller ne "::"} { + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $querycommand {*}$queryargs]] } @@ -2104,9 +2717,32 @@ tcl::namespace::eval punk::ns { #check for a direct match first if {[info commands ::punk::args::id_exists] ne ""} { if {![llength $queryargs]} { + #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" punk::args::update_definitions [list [namespace qualifiers $origin]] if {[punk::args::id_exists $origin]} { - return [uplevel 1 [list punk::args::usage {*}$opts $origin]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } } } } @@ -2116,7 +2752,7 @@ tcl::namespace::eval punk::ns { switch -- $initial_cmdtype { na - alias { #REVIEW - alias entry doesn't necessarily match command! - #consider using which_alias (wiki) + #consider using which_alias (wiki) set tgt [interp alias "" $origin] if {$tgt eq ""} { set tgt [interp alias "" [string trimleft $origin :]] @@ -2133,9 +2769,12 @@ tcl::namespace::eval punk::ns { #(possible curried arguments) #review - curried arguments could be for ensembles! set targetword $word1 - #set numvals [expr {[llength $queryargs]+1}] + #set numvals [expr {[llength $queryargs]+1}] #puts "ALIAS THROWBACK: namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]" #return [namespace eval :: [list punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] + if {!$scheme_received} { + dict unset opts -scheme + } return [namespace eval :: [list punk::ns::arginfo {*}$opts $targetword {*}[lrange $tgt 1 end] {*}$queryargs]] } @@ -2167,9 +2806,33 @@ tcl::namespace::eval punk::ns { #REVIEW - this doesn't cater for prefix callable subcommands set argcopy $queryargs if {[llength $queryargs]} { - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "====>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists [list $id {*}$queryargs]]} { - return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] + } } } #while {[llength $argcopy]} { @@ -2182,21 +2845,46 @@ tcl::namespace::eval punk::ns { #didn't find any exact matches #traverse from other direction taking prefixes into account - punk::args::update_definitions [list [namespace qualifiers $id]] + #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" + punk::args::update_definitions [list [namespace qualifiers $id]] if {[punk::args::id_exists $id]} { #cycle forward through leading values - set spec [punk::args::get_spec $id] + set specid $id + set specargs $queryargs if {[llength $queryargs]} { - set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + #jjj + set spec [punk::args::get_spec $id] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs set queryargs_untested $queryargs foreach q $queryargs { - if {[llength [dict get $spec LEADER_NAMES]]} { - set subitems [dict get $spec LEADER_NAMES] + if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { + set subitems [dict get $spec FORMS $fid LEADER_NAMES] if {[llength $subitems]} { set next [lindex $subitems 0] - set arginfo [dict get $spec ARG_INFO $next] + set arginfo [dict get $spec FORMS $fid ARG_INFO $next] - set allchoices [list] + set allchoices [list] set choices [punk::args::system::Dict_getdef $arginfo -choices {}] set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] if {[dict exists $choicegroups ""]} { @@ -2214,18 +2902,45 @@ tcl::namespace::eval punk::ns { lappend nextqueryargs $resolved_q lpop queryargs_untested 0 if {$resolved_q ne $q} { - #we have our first difference - recurse with new query args - #set numvals [expr {[llength $queryargs]+1}] + #we have our first difference - recurse with new query args + #set numvals [expr {[llength $queryargs]+1}] #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" - return [ punk::ns::arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested] + if {!$scheme_received} { + dict unset opts -scheme + } + return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] } #check if subcommands so far have a custom args def - #set currentid [list $querycommand {*}$nextqueryargs] - set currentid [list $id {*}$nextqueryargs] + #set currentid [list $querycommand {*}$nextqueryargs] + set currentid [list {*}$specid {*}$nextqueryargs] if {[punk::args::id_exists $currentid]} { set spec [punk::args::get_spec $currentid] + #--------------------------------------------------------------------------- + set form_names [dict get $spec form_names] + if {[llength $form_names] == 1} { + set fid [lindex $form_names 0] + } else { + #review - -form only applies to final command? + # -form must be a list if we have multiple levels of multi-form commands? + set opt_form [dict get $opts -form] + if {[string is integer -strict $opt_form]} { + if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid [lindex $form_names $opt_form] + } else { + if {$opt_form ni $form_names} { + error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" + } + set fid $opt_form + } + } + #--------------------------------------------------------------------------- + set specid $currentid + set specargs $queryargs_untested + set nextqueryargs [list] } else { #We can get no further with custom defs #It is possible we have a documented lower level subcommand but missing the intermediate @@ -2242,8 +2957,34 @@ tcl::namespace::eval punk::ns { } } } else { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } } + #puts "--->origin $specid queryargs: $specargs" + set origin $specid + set queryargs $specargs } } @@ -2261,10 +3002,10 @@ tcl::namespace::eval punk::ns { #the call: info object methods -all # seems to do the right thing as far as hiding unexported methods, and showing things like destroy # - which don't seem to be otherwise easily introspectable - set public_methods [info object methods $origin -all] + set public_methods [info object methods $origin -all] #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - + if {[llength $queryargs]} { set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { @@ -2277,13 +3018,13 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} new" -help\ "create object with specified command name. Arguments are passed to the constructor." - @values + @values }] set i 0 foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2294,7 +3035,31 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin new"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin new"] + } } create { set constructorinfo [info class constructor $origin] @@ -2304,7 +3069,7 @@ tcl::namespace::eval punk::ns { @cmd -name "${$origin} create" -help\ "create object with specified command name. Arguments following objectName are passed to the constructor." - @values -min 1 + @values -min 1 objectName -type string -help\ "possibly namespaced name for object instance command" }] @@ -2312,7 +3077,7 @@ tcl::namespace::eval punk::ns { foreach a $arglist { if {[llength $a] == 1} { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2323,29 +3088,77 @@ tcl::namespace::eval punk::ns { incr i } punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin create"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin create"] + } } destroy { #review - generally no doc # but we may want notes about a specific destructor set argdef [punk::lib::tstr -return string { - @id -id "(audodef)${$origin} destroy" + @id -id "(autodef)${$origin} destroy" @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." @values -min 0 -max 0 }] punk::args::define $argdef - return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + set queryargs_remaining [lrange $queryargs 1 end] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] + #return [punk::args::usage {*}$opts "(autodef)$origin destroy"] + } } default { - #use info object call to resolve callchain + #use info object call to resolve callchain #we assume the first impl is the topmost in the callchain # and its call signature is therefore the one we are interested in - REVIEW # we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? set implementations [::info object call $origin $c1] - #result documented as list of 4 element lists - #set callinfo [lindex $implementations 0] + #result documented as list of 4 element lists + #set callinfo [lindex $implementations 0] set oodef "" foreach impl $implementations { lassign $impl generaltype mname location methodtype @@ -2396,7 +3209,7 @@ tcl::namespace::eval punk::ns { switch -- [llength $a] { 1 { if {$i == [llength $arglist]-1 && $a eq "args"} { - #'args' is only special if last + #'args' is only special if last append argdef \n "args -optional 1 -multiple 1" } else { append argdef \n "$a" @@ -2422,6 +3235,7 @@ tcl::namespace::eval punk::ns { } } set choicelabeldict [dict create] + set choiceinfodict [dict create] foreach cmd $public_methods { switch -- $cmd { new - create - destroy { @@ -2437,13 +3251,16 @@ tcl::namespace::eval punk::ns { if {$location eq "object"} { #set id "[string trimleft $origin :] $cmd" ;# " " set id "$origin $cmd" + dict set choiceinfodict $cmd {{doctype ooo}} } else { #set id "[string trimleft $location :] $cmd" ;# " " set id "$location $cmd" + dict set choiceinfodict $cmd {{doctype ooc}} } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { - dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" + dict lappend choiceinfodict $cmd {doctype punkargs} } } break @@ -2451,6 +3268,7 @@ tcl::namespace::eval punk::ns { filter { } unknown { + dict set choiceinfodict $cmd {{doctype unknown}} } } } @@ -2458,11 +3276,11 @@ tcl::namespace::eval punk::ns { } } - set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review + set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" set idauto "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$idauto} + @id -id ${$idauto} @cmd -name "Object: ${$origin}" -help\ "Instance of class: ${$class} (info autogenerated)" @leaders -min 1 @@ -2492,6 +3310,7 @@ tcl::namespace::eval punk::ns { #presumably -choiceprefix should be zero in that case?? set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] set prefixes [dict get $ensembleinfo -prefixes] set map [dict get $ensembleinfo -map] set ns [dict get $ensembleinfo -namespace] @@ -2537,54 +3356,142 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] if {[llength $queryargs]} { - set match [tcl::prefix::match $subcommands [lindex $queryargs 0]] - if {$match in $subcommands} { - set subcmd [dict get $subcommand_dict $match] - #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - return [arginfo {*}$opts {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand + if {$posn_subcommand > 0} { + set params [lrange $queryargs 0 $posn_subcommand-1] + set remaining_queryargs [lrange $queryargs $posn_subcommand end] + } else { + set params [list] + set remaining_queryargs $queryargs } - } - - set namespaces [list] ;# usually only 1 or 2 namespaces - but could be any number. - dict for {sub subwhat} $subcommand_dict { - set ns [::namespace which $subwhat] - if {$ns ni $namespaces} { - lappend namespaces $ns + if {[llength $remaining_queryargs]} { + if {$prefixes} { + set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] + } else { + set match [lindex $remaining_queryargs 0] + } + if {$match in $subcommands} { + set subcmd [dict get $subcommand_dict $match] + #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + if {!$scheme_received} { + dict unset opts -scheme + } + #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] + #use tailcall so %caller% is reported properly in error msg + tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + } } } + set have_usageinfo [list] set is_ensemble [list] set is_object [list] - foreach ns $namespaces { - set nsinfo [lindex [punk::ns::nslist_dict [nsjoin [nsprefix $ns] *]] 0] - lappend have_usageinfo {*}[dict get $nsinfo usageinfo] - lappend is_ensemble {*}[dict get $nsinfo ensembles] - lappend is_object {*}[dict get $nsinfo ooobjects] + set is_class [list] + set is_native [list] + set namespaces [dict create] ;# usually only 1 or 2 namespaces - but could be any number. + dict for {sub subwhat} $subcommand_dict { + set targetfirstword [lindex $subwhat 0] + set ns [::namespace which $targetfirstword] + set ns [nsprefix $ns] + set targettail [namespace tail $targetfirstword] + if {![dict exists $namespaces $ns]} { + set nsinfo [lindex [punk::ns::nslist_dict [nsjoin $ns *]] 0] + dict set namespaces $ns $nsinfo + } else { + set nsinfo [dict get $namespaces $ns] + } + if {$targettail in [dict get $nsinfo usageinfo]} { + lappend have_usageinfo $sub + } + if {$targettail in [dict get $nsinfo ensembles]} { + lappend is_ensemble $sub + } + if {$targettail in [dict get $nsinfo ooobjects]} { + lappend is_object $sub + } + if {$targettail in [dict get $nsinfo ooclasses]} { + lappend is_class $sub + } + if {$targettail in [dict get $nsinfo native]} { + lappend is_native $sub + } } + #todo - synopsis? set choicelabeldict [dict create] + + set choiceinfodict [dict create] foreach sub $subcommands { + + if {$sub in $is_ensemble} { + dict lappend choiceinfodict $sub {doctype ensemble} + } + + if {$sub in $is_object} { + if {$sub in $is_class} { + dict lappend choiceinfodict $sub {doctype ooc} + } else { + dict lappend choiceinfodict $sub {doctype ooo} + } + } + + if {$sub in $is_native} { + dict lappend choiceinfodict $sub {doctype native} + } + if {$sub in $have_usageinfo} { - dict set choicelabeldict $sub " [Usageinfo_mark brightgreen]" - } elseif {$sub in $is_ensemble} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" - } elseif {$sub in $is_object} { - dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" + #dict set choiceinfodict $sub [list {doctype punkargs}] + dict lappend choiceinfodict $sub {doctype punkargs} } } - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] set autoid "(autodef)$origin" set argdef [punk::lib::tstr -return string { - @id -id ${$autoid} + @id -id ${$autoid} @cmd -help\ "(autogenerated) ensemble: ${$origin}" @leaders -min 1 }] + if {[llength $parameters] == 0} { + append argdef \n "@leaders -min 1" + } else { + append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" + foreach p $parameters { + append argdef \n "$p -type string -help { (leading ensemble parameter)}" + } + } append argdef \n $vline punk::args::define $argdef - return [punk::args::usage {*}$opts $autoid] + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { + # parsing error e.g Bad number of leading values + #override -scheme in opts with -scheme error + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] + } + #return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2650,14 +3557,41 @@ tcl::namespace::eval punk::ns { } if {[llength $queryargs]} { - #todo - something better - set msg "Undocumented or nonexistant subcommand $origin $queryargs" + #todo - something better ? + switch -- [dict get $opts -return] { + string { + set estyle "basic" + } + tableobject { + set estyle "minimal" + } + default { + set estyle "standard" + } + } + + if {[punk::args::id_exists $origin]} { + if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { + if {[dict get $opts -return] eq "tableobject"} { + return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] + } else { + return $parseresult + } + } else { + #show usage - with goodargs marked + if {!$scheme_received} { + dict set opts -scheme info + } + return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] + } + } + set msg "Undocumented or nonexistant command $origin $queryargs" append msg \n "$origin Type: $cmdtype" } else { if {$cmdtype eq "proc"} { set msg "Undocumented proc $origin" append msg \n "No argument processor detected" - append msg \n "function signature: $resolved $argl" + append msg \n "function signature: $resolved $argl" } else { set msg "Undocumented command $origin. Type: $cmdtype" } @@ -2667,15 +3601,15 @@ tcl::namespace::eval punk::ns { #todo - package up as navns proc corp {path} { - #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp + #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) if {[info exists punk::console::tabwidth]} { set tw $::punk::console::tabwidth } else { - set tw 8 + set tw 8 } - set indent [string repeat " " $tw] ;#match - #set indent [string repeat " " $tw] ;#A more sensible default for code - review + set indent [string repeat " " $tw] ;#match + #set indent [string repeat " " $tw] ;#A more sensible default for code - review if {[info exists ::auto_index($path)]} { set body "\n${indent}#corp# auto_index $::auto_index($path)" @@ -2695,7 +3629,7 @@ tcl::namespace::eval punk::ns { } #puts stderr "corp upns:$upns" - #set name [string trim $name :] + #set name [string trim $name :] #set origin [namespace origin ${upns}::$name] set origin [nseval $targetns [list ::namespace origin $name]] set resolved [nseval $targetns [list ::namespace which $name]] @@ -2703,7 +3637,7 @@ tcl::namespace::eval punk::ns { #An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! if {$origin ni [info procs $origin]} { - #It seems an interp alias of "::x"" behaves the same as "x" + #It seems an interp alias of "::x"" behaves the same as "x" #But we can't create both at the same time - and they have to be queried by the exact name. #So we query for alias with and without leading :: set alias_qualified [interp alias {} [string trim $origin :]] @@ -2727,7 +3661,7 @@ tcl::namespace::eval punk::ns { #depending on number of aliases in the chain return [list alias {*}$alias] } - } + } if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { append body \n "${indent}#corp# namespace origin $origin" } @@ -2737,7 +3671,7 @@ tcl::namespace::eval punk::ns { } if {![catch {package require textutil::tabify} errpkg]} { set bodytext [info body $origin] - #punk::lib::indent preserves trailing empty lines - unlike textutil version + #punk::lib::indent preserves trailing empty lines - unlike textutil version set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] append body [punk::lib::indent $bodytext $indent] } else { @@ -2880,17 +3814,17 @@ tcl::namespace::eval punk::ns { set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] if {!$ns_populated} { - #we will catch-run an auto_index entry if any - #auto_index entry may or may not be prefixed with :: + #we will catch-run an auto_index entry if any + #auto_index entry may or may not be prefixed with :: set keys [list] #first look for exact pkg_unqualified and ::pkg_unqualified #leave these at beginning of keys list if {[array exists ::auto_index($pkg_unqualified)]} { - lappend keys $pkg_unqualified - } + lappend keys $pkg_unqualified + } if {[array exists ::auto_index(::$pkg_unqualified)]} { - lappend keys ::$pkg_unqualified - } + lappend keys ::$pkg_unqualified + } #as auto_index is an array - we could get keys in arbitrary order set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]] lappend keys {*}$matches @@ -2902,8 +3836,8 @@ tcl::namespace::eval punk::ns { set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] while {!$ns_populated && $i < [llength $keys]} { #todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base - #e.g if we are loading ::x::y - #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc + #e.g if we are loading ::x::y + #only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc set k [lindex $keys $i] set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { @@ -2916,7 +3850,7 @@ tcl::namespace::eval punk::ns { } incr i } - + } } } @@ -2924,7 +3858,7 @@ tcl::namespace::eval punk::ns { if {[llength $cmdargs]} { set binding {} #if {[info level] == 1} { - # #up 1 is global + # #up 1 is global # set get_vars [list info vars] #} else { # set get_vars [list info locals] @@ -2955,7 +3889,7 @@ tcl::namespace::eval punk::ns { } else { #A variable can show in the results for 'info vars' (or nsvars) but still not exist. e.g a 'variable x' declaration in the namespace where the variable has never been set } - } + } return [dict create vars $capturevars arrs $capturearrs] } } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) } ] @@ -2963,7 +3897,7 @@ tcl::namespace::eval punk::ns { set arglist [lassign $cmdargs scriptblock] if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} { - #one liner without use of $args + #one liner without use of $args append scriptblock { {*}$args} #tailcall apply [list args [string cat $scriptblock { {*}$args}] $ns] {*}$arglist } @@ -3043,7 +3977,7 @@ tcl::namespace::eval punk::ns { error "nsimport_noclobber error namespace $source_ns not found" } - set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] + set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] set a_commands [info commands $pat] #puts "-->commands:'$a_commands'" set a_tails [lmap v $a_commands {tcl::namespace::tail $v}] @@ -3053,11 +3987,11 @@ tcl::namespace::eval punk::ns { foreach m $matches { #we will be using namespace import one by one on commands. #we must protect glob chars that may exist in the actual command names. - #e.g nsimport_noclobber ::punk::ansi::a? + #e.g nsimport_noclobber ::punk::ansi::a? # will import a+ and a? #but nsimport_noclobber {::punk::ansi::a\?} # must import only a? - set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] + set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] if {$m ni $a_exported_tails} { lappend a_exported_tails $m } @@ -3071,7 +4005,7 @@ tcl::namespace::eval punk::ns { set imported_commands [list] if {[namespace exists $nstemp]} { namespace delete $nstemp - } + } namespace eval $nstemp {} foreach e $a_exported_tails { set imported [apply {{tgtns func srcns pfx tmpns} { @@ -3151,13 +4085,13 @@ tcl::namespace::eval punk::ns { @id -id ::i+ @cmd -name "i+" -help\ "Display command help side by side" - @values - cmds -multiple 1 -help\ + @values + cmd -multiple 1 -help\ "Command names for which to show help info" } interp alias {} i+ {}\ .=args> punk::args::get_by_id ::i+ |argd>\ - .=>2 dict get values cmds |cmds>\ + .=>2 dict get values cmd |cmds>\ .=cmds>2 lmap c {i -return tableobject {*}$c} |objs>\ .=objs>2 lmap t {$t configure -show_vseps 0 -show_edge 1} |>\ .=objs>2 lmap t {$t print} |tables>\ @@ -3179,9 +4113,9 @@ tcl::namespace::eval punk::ns { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ns [tcl::namespace::eval punk::ns { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm index a39fceaf..2ab1fb01 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm @@ -100,8 +100,12 @@ namespace eval punk::repo { subcommand -type string -choicecolumns 8 -choicegroups { "frequently used commands" {${$maincommands}} "" {${$othercmds}} - } + } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}} }] + #-choiceinfo { + # add {{doctype punkargs}} + # diff {{doctype punkargs}} + #} return $result } @@ -112,7 +116,7 @@ namespace eval punk::repo { # @id -id ::punk::repo::fossil_proxy # @cmd -name fossil -help "fossil executable # " - # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}} # } ""] lappend PUNKARGS [list { @@ -129,7 +133,7 @@ namespace eval punk::repo { @dynamic @id -id "::punk::repo::fossil_proxy diff" @cmd -name "fossil diff" -help "fossil diff" - @argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} + @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} } ""] lappend PUNKARGS [list { #todo - remove this comment - testing dynamic directive @@ -137,7 +141,7 @@ namespace eval punk::repo { @id -id "::punk::repo::fossil_proxy add" @cmd -name "fossil add" -help "fossil add " - @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} } ""] #TODO #lappend PUNKARGS [list { @@ -145,7 +149,7 @@ namespace eval punk::repo { # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @cmd -name "fossil add" -help "fossil add # " - # @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} + # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # } ""] lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} diff --git a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm index 99bc359d..4ba74656 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm @@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip { expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) | ($hour << 11) | ($min << 5) | ($sec >> 1)} } - + punk::args::define { + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -help\ + "Walk the directory structure starting at base/<-subpath> + and return a list of the files and folders encountered. + Resulting paths are relative to base unless -resultrelative + is supplied. + Folder names will end with a trailing slash. + " + -resultrelative -optional 1 -help\ + "Resulting paths are relative to this value. + Defaults to the value of base. If empty string + is given to -resultrelative the paths returned + are effectively absolute paths." + -emptydirs -default 0 -type boolean -help\ + "Whether to include directory trees in the result which had no + matches for the given fileglobs. + Intermediate dirs are always returned if there is a match with + fileglobs further down even if -emptdirs is 0. + " + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" -help\ + "May contain glob chars for folder elements" + @values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } proc walk {args} { #*** !doctools #[call [fun walk] [arg ?options?] [arg base]] #[para] Walk a directory tree rooted at base #[para] the -excludes list can be a set of glob expressions to match against files and avoid - #[para] e.g + #[para] e.g #[example { # punk::zip::walk -exclude {CVS/* *~.#*} library #}] #todo: -relative 0|1 flag? - set argd [punk::args::get_dict { - @id -id ::punk::zip::walk - @cmd -name punk::zip::walk -help\ - "Walk the directory structure starting at base/<-subpath> - and return a list of the files and folders encountered. - Resulting paths are relative to base unless -resultrelative - is supplied. - Folder names will end with a trailing slash. - " - -resultrelative -optional 1 -help\ - "Resulting paths are relative to this value. - Defaults to the value of base. If empty string - is given to -resultrelative the paths returned - are effectively absolute paths." - -emptydirs -default 0 -type boolean -help\ - "Whether to include directory trees in the result which had no - matches for the given fileglobs. - Intermediate dirs are always returned if there is a match with - fileglobs further down even if -emptdirs is 0. - " - -excludes -default "" -help "list of glob expressions to match against files and exclude" - -subpath -default "" -help\ - "May contain glob chars for folder elements" - @values -min 1 -max -1 - base - fileglobs -default {*} -multiple 1 - } $args] + set argd [punk::args::parse $args withid ::punk::zip::walk] set base [dict get $argd values base] set fileglobs [dict get $argd values fileglobs] set subpath [dict get $argd opts -subpath] @@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip { + punk::args::define { + @id -id ::punk::zip::Addentry + @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + @opts + -comment -default "" -help "An optional comment specific to the added file" + @values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } + # Addentry - was Mkzipfile -- # # FIX ME: should handle the current offset for non-seekable channels @@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip { #[para] You can provide a -comment for the file. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. - set argd [punk::args::get_dict { - @id -id ::punk::zip::Addentry - @cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' - return a central directory file record" - @opts - -comment -default "" -help "An optional comment specific to the added file" - @values -min 3 -max 4 - zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" - base -help "base path for entries" - path -type file -help "path of file to add" - zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe - Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::Addentry] set zipchan [dict get $argd values zipchan] set base [dict get $argd values base] set path [dict get $argd values path] @@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip { # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) #### + + punk::args::define { + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ + -help "Create a zip archive in 'filename'" + @opts + -offsettype -default "archive" -choices {archive file}\ + -help "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix. + " + -return -default "pretty" -choices {pretty list none}\ + -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none\ + -help "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs + " + -runtime -default ""\ + -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review) + " + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "The new zip archive will scan for contents within this folder or current directory if not provided. + Note that this will + " + -base -default ""\ + -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + + @values -min 1 -max -1 + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help "list of glob patterns to match. + Only directories with matching files will be included in the archive." + } + # zip::mkzip -- # # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt - # + # proc mkzip {args} { #todo - doctools - [arg ?globs...?] syntax? @@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip { #[para] If a file already exists, an error will be raised. #[para] Call 'punk::zip::mkzip' with no arguments for usage display. - set argd [punk::args::get_dict { - @id -id ::punk::zip::mkzip - @cmd -name punk::zip::mkzip\ - -help "Create a zip archive in 'filename'" - @opts - -offsettype -default "archive" -choices {archive file}\ - -help "zip offsets stored relative to start of entire file or relative to start of zip-archive - Only relevant if the created file has a script/runtime prefix. - " - -return -default "pretty" -choices {pretty list none}\ - -help "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none\ - -help "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs - " - -runtime -default ""\ - -help "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review) - " - -comment -default ""\ - -help "An optional comment for the archive" - -directory -default ""\ - -help "The new zip archive will scan for contents within this folder or current directory if not provided. - Note that this will - " - -base -default ""\ - -help "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" - -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - - @values -min 1 -max -1 - filename -type file -default ""\ - -help "name of zipfile to create" - globs -default {*} -multiple 1\ - -help "list of glob patterns to match. - Only directories with matching files will be included in the archive." - } $args] - + set argd [punk::args::parse $args withid ::punk::zip::mkzip] set filename [dict get $argd values filename] if {$filename eq ""} { error "mkzip filename cannot be empty string" diff --git a/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.0.tm new file mode 100644 index 00000000..dfbd9898 Binary files /dev/null and b/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.0.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm b/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm new file mode 100644 index 00000000..5492a18c Binary files /dev/null and b/src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm differ 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 9f4e75ee..ebd18fc1 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm @@ -140,16 +140,18 @@ tcl::namespace::eval textblock { # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # "algorithm choice" - - punk::args::define { - @dynamic - @id -id ::textblock::use_hash - @cmd -name "textblock::use_hash" -help\ - "Hashing algorithm to use for framecache lookup. - 'none' may be slightly faster but less compact - when viewing textblock::framecache" - @values -min 0 -max 1 - hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} + namespace eval argdoc { + set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]} + punk::args::define { + @dynamic + @id -id ::textblock::use_hash + @cmd -name "textblock::use_hash" -help\ + "Hashing algorithm to use for framecache lookup. + 'none' may be slightly faster but less compact + when viewing textblock::framecache" + @values -min 0 -max 1 + hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP} + } } proc use_hash {args} { #set argd [punk::args::get_by_id ::textblock::use_hash $args] @@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock { -size -type integer\ -default 15\ -optional 1\ - -range {1 15} + -range {1 ""} -direction -default horizontal\ -choices {horizontal vertical}\ -help\ - "When rainbow is in the colour list, - this also affects the direction of - colour changes" - @values -min 0 -max 2 + "Direction of character increments. + When rainbow is in the colour list, + the colour stripes will be oriented + in this direction. + " + @values -min 0 -max 1 colour -type list -default {} -optional 1 -help\ "List of Ansi colour names - e.g. testblock 10 {white Red} + e.g. testblock -size 10 {white Red} produces a block of character 10x10 with white text on red bacground @@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock { set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + if {$size <= 15} { + set charsubset [lrange $chars 0 $size-1] + } else { + set numsets [expr {int(ceil($size / 15.0))}] + set longset [concat {*}[lrepeat $numsets $chars]] + set charsubset [lrange $longset 0 $size-1] + + set longbows [concat {*}[lrepeat $numsets $rainbow_list]] + set rainbow_list [lrange $longbows 0 $size-1] + } if {"noreset" in $colour} { set RST "" } else { @@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock { append row $c } append row $RST - append block $row\n + append block $row \n } set block [tcl::string::trimright $block \n] return $block } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST + if {$direction eq "vertical"} { + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [tcl::string::repeat $ch $size] + } + set block [::join $rows \n] + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block + } else { + set block "" + for {set r 0} {$r < $size} {incr r} { + append block [::join $charsubset ""] \n + } + if {[llength $colour]} { + set block [a+ {*}$colour]$block$RST + } + return $block } - return $block } } interp alias {} testblock {} textblock::testblock @@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock { proc ::textblock::join1 {args} { - lassign [punk::args::get_dict { + lassign [punk::args::parse $args withdef { + @id -id ::textblock::join1 -ansiresets -default 1 -type integer blocks -type string -multiple 1 - } $args] _l leaders _o opts _v values + }] _l leaders _o opts _v values set blocks [tcl::dict::get $values blocks] set idx 0 @@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock { #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner #" - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::textblock::join_basic2 -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -ansiresets -type any -default auto blocks -type any -multiple 1 - } $args] + }] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock { #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #they may however still be 'ragged' ie differing line lengths proc ::textblock::join {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - #-ansireplays is always on (if ansi detected) #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets @@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock { } proc ::textblock::join2 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock { } # This calls textblock::pad per cell :/ proc ::textblock::join3 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] #-ansireplays is always on (if ansi detected) @@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock { NOTE: more options available - argument definition is incomplete" @opts - -return -choices {table tableobject} + -return -default table -choices {table tableobject} -rows -type list -default "" -help\ "A list of lists. Each toplevel element represents a row. @@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock { -help "restrict to keys matching memberglob." }] #append spec \n "frametype -help \"A predefined \"" - punk::args::get_dict $spec $args + punk::args::parse $args withdef $spec return }